home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / yerk / mps231ss.hqx / Mops source / Nuc source / Handlers.asm < prev    next >
Assembly Source File  |  1993-02-25  |  167KB  |  7,035 lines
  1. ;    =======================================
  2.  
  3. ;        COMPILATION HANDLERS
  4.  
  5. ;    =======================================
  6.  
  7. ; This is our code generator.  HANDLERS is the entry point.  We have only
  8. ; one, since A5 has to be saved and restored, and this simplifies things.
  9. ;
  10. ; Entered with:
  11. ;
  12. ;    D0 = selector for handler routine to be executed
  13. ;    D1 = saved A5 (modbase)
  14. ;    D2 = opcode for ->, ++> etc.
  15. ;
  16. ; Individual routines may have other parameters on the stack.
  17.  
  18.  
  19. ; A compilation handler is called during compilation to compile the machine
  20. ; code for a Mops word.  We do things this way since words compile into a
  21. ; variety of different machine code sequences.  The handler code
  22. ; immediately follows the header of the word.  This is the same code as is
  23. ; passed here in D0.
  24.  
  25. ; Just in front of the handler routine itself we put a 2-byte value which gives
  26. ; the offset from the cfa (= compilation address) of the word being compiled
  27. ; to its "body".  This is a varying quantity in this implementation, and this
  28. ; scheme allows >BODY to get the right answer.  The HNDLR macro puts this
  29. ; 2-byte quantity in.
  30.  
  31. ; We take the opportunity to include some local optimization.
  32. ; This is the best kind for Forth/Mops, where the programmer (rightly) has
  33. ; responsibility for higher-level efficiencies.  The optimization we do
  34. ; is aimed at speeding common sequences, rather than picking up everything
  35. ; under the sun.
  36.  
  37. hbase    equ    *+32766
  38.  
  39.     jtbl    handlers
  40.  
  41.     ref    comma,wcomma,ncomma,swap,pcomp,length,doPAtAbs,star,slash
  42.  
  43. _debugger    trapw    $a9ff
  44.  
  45.     ipath    "::mops source:nuc source:"
  46.     incl    "OD.asm"
  47.  
  48. ;        ============================
  49.  
  50. ;                 MACROS etc.
  51.  
  52. ;        ============================
  53.  
  54. ; Flag codes for various word types.  The actual values are quite
  55. ; arbitrary.
  56.  
  57. inline    equ    0
  58. docode    equ    1
  59. docol    equ    3
  60. docon    equ    5
  61. doval    equ    6
  62. dovbl    equ    8
  63. dovec    equ    9
  64. spec    equ    10
  65. inlinex    equ    11
  66.  
  67. InstMk_con    equ    $4AFC
  68.  
  69.  
  70. HNDLR    macrox    &1,&2    ; label, >body offset
  71.     dc.w    call_h-hbase
  72.     dc.w    &2
  73. &1
  74.     endm
  75.  
  76. ;Push and pop macros - modified to use A6 instead of A7.
  77.  
  78. push.b    macrox    &1
  79.     move.b    &1,-(a6)
  80.     endm
  81.  
  82. push.w    macrox    &1
  83.     move.w    &1,-(a6)
  84.     endm
  85.  
  86. push    macrox    &1
  87.     move.w    &1,-(a6)
  88.     endm
  89.  
  90. push.l    macrox    &1
  91.     move.l    &1,-(a6)
  92.     endm
  93.  
  94. pop.b    macrox    &1
  95.     move.b    (a6)+,&1
  96.     endm
  97.  
  98. pop.w    macrox    &1
  99.     move.w    (a6)+,&1
  100.     endm
  101.  
  102. pop    macrox    &1
  103.     move.w    (a6)+,&1
  104.     endm
  105.  
  106. pop.l    macrox    &1
  107.     move.l    (a6)+,&1
  108.     endm
  109.  
  110. compyl    macrox    &1
  111.     LEA    &1-hbase(A4),A0
  112.     PUSH.L    A0
  113.     JSR    pcomp
  114.     endm
  115.  
  116. ; Note: here we can only call pcomp with inline words, and then pcomp
  117. ; doesn't call us back.  This is essential - Handlers is definitely not
  118. ; reentrant!
  119.  
  120.  
  121. INL    macrox    &1
  122.     dc.w    .xx-*-2
  123. &1    &1_m
  124. .xx
  125.     endm
  126.  
  127.  
  128. CODE    macrox    &1,&2,&3    ; label, flag, opt
  129.  
  130.     if    &2 = inline
  131.     inl    &1
  132.     else
  133.     error    "Only inline allowed on definitions in Handlers"
  134.     endi
  135.     endm
  136.  
  137.  
  138. NOHEAD    macrox    &1,&2    ; label, flag
  139.     code    &1,&2
  140.     endm
  141.  
  142. GET.L    macrox    &1,&2
  143.     MOVE.L    &1,A1
  144.     MOVE.L    (A1),&2
  145.     endm
  146.  
  147. GETA    macrox    &1,&2
  148.     MOVE.L    &1,&2
  149.     endm
  150.  
  151. GET.W    macrox    &1,&2
  152.     MOVE.L    &1,A1
  153.     MOVE.W    (A1),&2
  154.     endm
  155.  
  156. GET.B    macrox    &1,&2
  157.     MOVE.L    &1,A1
  158.     MOVE.B    (A1),&2
  159.     endm
  160.  
  161. PUT.L    macrox    &1,&2
  162.     MOVE.L    &2,A1
  163.     MOVE.L    &1,(A1)
  164.     endm
  165.  
  166. PUT.W    macrox    &1,&2
  167.     MOVE.L    &2,A1
  168.     MOVE.W    &1,(A1)
  169.     endm
  170.  
  171. PUT.B    macrox    &1,&2
  172.     MOVE.L    &2,A1
  173.     MOVE.B    &1,(A1)
  174.     endm
  175.  
  176. INC.L    macrox    &1,&2
  177.     MOVE.L    &2,A1
  178.     ADD.L    &1,(A1)
  179.     endm
  180.  
  181. pushop    macrox    &1
  182.     PUSH.W    &1-hbase(A4)
  183.     CLR.W    -(A6)
  184.     endm
  185.  
  186. compop    macrox    &1
  187.     pushop    &1
  188.     JSR    wcomma
  189.     endm
  190.  
  191. compopl    macrox    &1
  192.     push.l    &1
  193.     jsr    comma
  194.     endm
  195.  
  196.  
  197. ;    ============================
  198.  
  199. ;        ENTRY POINT
  200.  
  201. ;    ============================
  202.  
  203. Handlers
  204.     LEA    hbase,A0
  205.     MOVEM.L    D1-D7/A2/A4,savedRegs-hbase(A0)
  206.             ; Save regs we need
  207.             ;  -- D1 is actually the A5 value
  208.     MOVE.L    (A7)+,savedRA-hbase(A0)    ;  and rtn addr
  209.     MOVE.L    A0,A4    ;  A4 is now our base register
  210.     NEG.W    D0
  211.     LEA    htable,A0
  212.     MOVE.W    0(A0,D0.W),D0
  213.     JSR    0(A4,D0.W)
  214.  
  215. hndExit    MOVEQ    #0,D0    ; Normal return point
  216. hndErr            ; We return here on an error, with
  217.             ; err# in D0
  218.     MOVEM.L    savedRegs,D1-D7/A2/A4
  219.     MOVE.L    D1,A5    ; Restore regs
  220.     MOVE.L    savedRA,A0
  221.     JMP    (A0)
  222.  
  223. savedRegs
  224. savedA5    long    ; D1 (really A5 = modbase)
  225. opcode    long    ; D2 = opcode
  226.     long    5    ; D3-D7
  227.     long    ; A2
  228. savedA4    long    ; A4
  229. savedRA    long
  230.  
  231.  
  232. htable    dc.w    hsetup-hbase,call_h-hbase,const_h-hbase
  233.     dc.w    val_h-hbase,create_h-hbase,vect_h-hbase,pm_h-hbase
  234.     dc.w    at_h-hbase,store_h-hbase,call_h-hbase,reg_h-hbase
  235.     dc.w    obj_h-hbase,does_h-hbase,loc_h-hbase
  236.     dc.w    LitAddr-hbase,pushDesc_h-hbase,dummy-hbase
  237.     dc.w    Literal-hbase,CompExit-hbase
  238.     dc.w    CompJSRLong-hbase,pif-hbase,compPlLoop-hbase
  239.     dc.w    hmentry-hbase,hplentry-hbase,heb-hbase
  240.     dc.w    hStkObj-hbase,hDoEx-hbase,hgenaddr-hbase,hgenxaddr-hbase
  241.     dc.w    class_h-hbase,compimp-hbase,objPtr_h-hbase,bit_h-hbase
  242.     dc.w    swap_h-hbase,hLoadBA-hbase,FixDoes-hbase,hPatch-hbase
  243.     dc.w    Floc_h-hbase,Fcon_h-hbase,Fval_h-hbase
  244.     dc.w    FP1_h-hbase,FP2_h-hbase,FPcmp_h-hbase,hCompFPUL-hbase
  245.     dc.w    FCRcon_h-hbase,class_in_mod_h-hbase,imported_h-hbase
  246.     dc.w    hColA-hbase,shift_h-hbase,hDefnEnd-hbase,Fat_h-hbase
  247.     dc.w    Fst_h-hbase,builds_h-hbase,MultDiv_h-hbase
  248.  
  249. dummy    dc.w    $FFEF    ; Unassigned handler code
  250.  
  251. ;    ===============================
  252.  
  253. startGlobs
  254.  
  255. dp    long
  256. fmkCnt    long
  257. callOut    long
  258. CCmpFlg    long
  259. colaFlg    long
  260. optq    long
  261. methodq    long
  262. numPL    long
  263. numP    long
  264. numF    long
  265. FltFlg    long
  266. locNo    long
  267. localq    long
  268. numLast    long
  269. modEntry    long
  270. saveTandS    long
  271. xJsrToVect    long
  272. xAtAbs    long
  273. xMulX    long
  274. xPushBool    long
  275. MBcomp    long
  276. SAcomp    long
  277. HWPavail    long
  278. state    long
  279. UseFPUq    long
  280. ptrFPdisp    long
  281. ptrFPdisp2    long
  282. ptrFPnew    long
  283. ptrFPULit    long
  284. ptrLfloat    long
  285. ptrToLfloat    long
  286. ptrToFval    long
  287. ptrLFdisp    long
  288. ExtraLocals    long
  289. HeldMod    long
  290. EBmod    long
  291. MethIndex    long
  292. inhibitMBq    long
  293.  
  294. OurGlobs
  295.  
  296. hsetup    MOVE.L    (A7)+,A0    ; Save return addr
  297.     MOVE.L    (A7)+,D2    ; and another rtn addr from higher up
  298.     LEA    OurGlobs,A1
  299.     MOVEQ    #(ourGlobs-startGlobs)/4-1,d0    ; #globs - 1 -- keeps changing!
  300. .suLoop    MOVE.L    (A7)+,-(A1)
  301.     DBRA    D0,.suLoop
  302.  
  303.     move.l    d2,-(a7)    ; Restore return addrs
  304.     move.l    a0,-(a7)
  305.  
  306.     moveq    #-1,d0
  307.     put.l    d0,MBcomp
  308.     lea    XLOD,a0
  309.     bsr    ClearOD
  310.     push.l    ExtraLocals
  311.     bsr    SetAddr
  312.     moveq    #0,d0
  313.     bsr    LoadBase
  314.     move.l    opDispl,XLdispl-hbase(a4)
  315.     moveq    #0,d0
  316.     bsr    EAbits
  317.     move.w    d0,XLeaBits-hbase(a4)
  318.  
  319.     lea    OD,a1    ; Return OD addr for main prog
  320.     rts
  321.  
  322. ;    ============================
  323.  
  324. ;    INSTRUCTIONS FOR COMPILATION
  325.  
  326. ;    ============================
  327.  
  328. xpush    PUSH.L    2(A3)
  329. xpushi    PUSH.L    #0
  330. xpushD0    PUSH.L    D0
  331. xpushD1    PUSH.L    D1
  332. xpushD2    PUSH.L    D2
  333. xpushA0    PUSH.L    A0
  334. xpopD0    POP.L    D0
  335. xpopD2    POP.L    D2
  336. xpopA0    POP.L    A0
  337. xpopA1    POP.L    A1
  338. xpopD7    POP.L    D7
  339. xTSTstk    move.l    (A6),d0
  340. xTSTstkPop    move.l    (A6)+,d0
  341. xmvA2D0    move.l    a2,d0
  342. xmvD0D2    move.l    d0,d2
  343. xmvD2D0    move.l    d2,d0
  344. xmvD0A0    move.l    d0,a0
  345. xmvD0A1    move.l    d0,a1
  346. xmvA1D2    move.l    a1,d2
  347. xmvD0A2    MOVE.L    D0,A2
  348. xmvA2A0    MOVE.L    A2,A0
  349. xmvD1A0    MOVE.L    D1,A0
  350. xmvD1stk    MOVE.L    D1,(A6)
  351. xMv2ndD0    move.l    4(a6),d0
  352. xRpshA0    MOVE.L    A0,-(A7)
  353. xMentry    MOVE.L    A2,-(A7)
  354.     MOVE.L    A0,A2
  355. xRpopA2    MOVE.L    (A7)+,A2
  356. xRpshD7    MOVE.L    D7,-(A7)
  357. xRpopD7    MOVE.L    (A7)+,D7
  358. xRpshA5    move.l    a5,-(a7)
  359. xRpopA5    move.l    (a7)+,a5
  360. xPopRpsh    MOVE.L    (A6)+,-(A7)
  361. xmvA3D0    MOVE.L    A3,D0
  362. xmoveEA    MOVE.L    2(A3),D0
  363. x2ndToA0    MOVE.L    4(A6),A0
  364. xD2ByA0    MOVE.L    D2,(A0)
  365. xpopByA0    POP.L    (A0)
  366. xJsrA0    JSR    (A0)
  367. xMMtoR    MOVEM.L    D4-D7,-(A7)
  368. xMMfrR    MOVEM.L    (A7)+,D4-D7
  369. xMMpop    MOVEM.L    (A6)+,D5-D7
  370.  
  371. xChnSub    SUB.L    (A6)+,D1    ; These 2 must go together
  372. xNegD1    NEG.L    D1
  373. xSubD1    SUB.L    (A6),D1
  374. xExtD1    ext.w    d1
  375.     ext.l    d1
  376.  
  377. xRTS    RTS
  378.  
  379. xTSTA0    MOVE.L    A0,D0    ; Can't do a TST on A0, but this MOVE has
  380.             ;  the same effect on the CC!
  381. xAddD1A0    add.l    d1,a0
  382. xAddStkA0    add.l    (a6)+,a0
  383.  
  384. xgxself    ADD.W    -2(A0),A0
  385.     ADD.W    -2(A0),A0
  386. ;    ADDQ    #4,A0
  387.  
  388. xclr    CLR.L    -(A6)
  389. xclrD0    CLR.B    D0
  390. xbsr    BSR    .dummy
  391.  
  392. xFPmove    movem.l    (a0),d0-d2
  393.     movem.l    d0-d2,(a1)
  394.  
  395. xFPmove2    movem.l    (a1),d0-d2
  396.     movem.l    d0-d2,(a0)
  397.  
  398. xsubStk    SUB.L    D0,(A6)
  399.  
  400. xadds    ADD.B    D0,D0
  401.     SUB.B    D0,D0
  402.     AND.B    D0,D0
  403.     OR.B    D0,D0
  404.     EOR.B    D0,D0
  405.     CMP.B    D0,D0
  406.     NOP
  407.     NEG.B    D0
  408.     NOT.B    D0
  409.  
  410. xaddq    ADDQ.B    #8,D0
  411.     SUBQ.B    #8,D0
  412.  
  413. xaddi    dc.w    $0600,$0400,$0200,$0000,$0A00,$0C00
  414.  
  415. xcmp    CMPM.L    (A6)+,(A6)+
  416. xcmpD2    CMP.L    (A6),D2
  417.  
  418. ; Floating point ops
  419.  
  420.     dc.w    $F200,$0038    ; FCMP
  421. xFPops    dc.w    0,0    ; FP move is handled elsewhere
  422.     dc.w    $F200,$0022    ; FADD
  423.     dc.w    $F200,$0023    ; FMUL
  424.     dc.w    0,0
  425.     dc.w    0,0
  426.     dc.w    0,0
  427.     dc.w    0,0
  428.     dc.w    0,0
  429.     dc.w    $F200,$0028    ; FSUB
  430.     dc.w    $F200,$0020    ; FDIV
  431.     dc.w    0,0
  432.     dc.w    0,0
  433.     dc.w    0,0
  434.     dc.w    0,0
  435.     dc.w    0,0
  436.     dc.w    0,0
  437.     dc.w    0,0
  438.     dc.w    0,0
  439.     dc.w    0,0
  440.     dc.w    0,0
  441.     dc.w    $F200,$0018    ; FABS
  442.     dc.w    $F200,$001A    ; FNEG
  443.     dc.w    $F200,$000E    ; FSIN
  444.     dc.w    $F200,$001D    ; FCOS
  445.     dc.w    $F200,$000F    ; FTAN
  446.     dc.w    $F200,$000A    ; FATAN
  447.     dc.w    $F200,$0004    ; FSQRT
  448.  
  449. ; SANE codes
  450.  
  451. xSANE    dc.w    $0000    ; FADDX
  452.     dc.w    $0004    ; FMULX
  453.     dc.w    0
  454.     dc.w    0
  455.     dc.w    0
  456.     dc.w    0
  457.     dc.w    0
  458.     dc.w    $0002    ; FSUBX
  459.     dc.w    $0006    ; FDIVX
  460.     dc.w    0
  461.     dc.w    0
  462.     dc.w    0
  463.     dc.w    0
  464.     dc.w    0
  465.     dc.w    0
  466.     dc.w    0
  467.     dc.w    0
  468.     dc.w    0
  469.     dc.w    0
  470.     dc.w    $003E    ; Special code for ABS - we don't need
  471.             ;  to call SANE
  472.     dc.w    $003F    ; NEG ditto
  473.     dc.w    $0018    ; FSINX
  474.     dc.w    $001A    ; FCOSX
  475.     dc.w    $001C    ; FTANX
  476.     dc.w    $001E    ; FATANX
  477.     dc.w    $0012    ; FSQRTX
  478.  
  479. ; Table to convert from integer condition encodings to the equivalent
  480. ; floating-point codes.
  481.  
  482. int2FPconditions
  483.     dc.b    0    ; Undefined
  484.     dc.b    0    ; Undefined
  485.     dc.b    0    ; HI has no equivalent
  486.     dc.b    0    ; LS has no equivalent
  487.     dc.b    0    ; HS has no equivalent
  488.     dc.b    0    ; LO has no equivalent
  489.     dc.b    $E    ; NE
  490.     dc.b    $1    ; EQ
  491.     dc.b    0    ; Undefined
  492.     dc.b    0    ; Undefined
  493.     dc.b    0    ; Undefined
  494.     dc.b    0    ; Undefined
  495.     dc.b    $13    ; GE
  496.     dc.b    $14    ; LT
  497.     dc.b    $12    ; GT
  498.     dc.b    $15    ; LE
  499.  
  500.  
  501. ;    =========================
  502.  
  503. ;        FLAGS etc.
  504.  
  505. ;    =========================
  506.  
  507. ObjPtr    long
  508. ivPtr    long
  509. methCfa    long
  510. CMPdesc    long
  511. FetchSize    dc.b    2
  512. ForceToR    byte
  513. svForceToR    byte
  514. InhibitClr    byte
  515. svInhibitClr
  516.     byte
  517. Rcond    byte
  518. Flocq    byte
  519. FatStq    byte
  520. Condition    byte
  521. WhichA    byte
  522. FPA    byte
  523. FPdispFlg    byte
  524. DPbacked    byte
  525. ChnReg    byte
  526.     align
  527.  
  528. .dummy
  529.  
  530. ;        ===========================
  531.  
  532. ;            UTILITY SUBROUTINES
  533.  
  534. ;        ===========================
  535.  
  536. FlushCache
  537.     loc
  538.     movem.l    d0/d1/a0/a1,-(a6)    ; Save regs
  539.     get.b    HWPavail,D0
  540.     beq.s    .out    ; Out if HWPriv trap not available
  541.     moveq    #1,D0    ; Code 1 means flush the instrn cache
  542.     dc.w    $A198    ; HWPriv trap
  543. .out    movem.l    (a6)+,d0/d1/a0/a1    ; Restore regs
  544.     rts
  545.  
  546.  
  547. ; LowBit finds the bit number of the lowest-order "1" bit in D1.
  548. ; Returns bit number in D0, and CC as follows:
  549. ;    EQ  =  D1 was zero (D0 will be unchanged in this case)
  550. ;    LT  =  Just one bit was set
  551. ;    GT  =  More than one bit was set
  552. ;
  553. ; D1 is preserved.
  554.  
  555. LowBit    loc
  556.     tst.l    d1
  557.     beq.s    .lbOut    ; If D1 is zero, straight out with "EQ"
  558.     push.l    d1    ; Save D1
  559.     moveq    #31,d0
  560. .lp    lsr.l    #1,d1
  561.     dbcs    d0,.lp
  562.     beq.s    .oneBit
  563.     pop.l    d1    ; Restore D1 before we set CC
  564.     sub.w    #31,d0    ; Set D0 to bit number
  565.     neg.w    d0
  566.     move    #0,CCR    ; Set "GT" (d0 may have been zero)
  567. .lbOut    rts
  568.  
  569. .oneBit    pop.l    d1
  570.     sub.w    #31,d0
  571.     neg.w    d0
  572.     move    #8,CCR    ; Set "LT"
  573.     rts
  574.  
  575.  
  576. ; BitReverse reverses the bits in the low word of D0.  Used for compiling
  577. ; MOVEM and FMOVEM instructions.  Leaves the top word of D0 unchanged.
  578.  
  579. BitReverse
  580.     movem.l    d1/d2,-(a6)
  581.     moveq    #15,d2
  582.     move.w    d0,d1
  583.     move    #4,ccr
  584. .lp2    roxr.w    #1,d0
  585.     roxl.w    #1,d1
  586.     dbra    d2,.lp2
  587.     move.w    d1,d0
  588.     movem.l    (a6)+,d1/d2
  589.     rts
  590.  
  591.  
  592. WdChk    loc
  593.     CMP.L    #-32768,D0
  594.     BLT.S    .out
  595.     CMP.L    #32767,D0
  596.     BGT.S    .out
  597.     MOVE    #4,CCR    ; Set "EQ"
  598. .out    RTS
  599.  
  600. ByteChk    loc
  601.     CMP.L    #-128,D0
  602.     BLT.S    .out
  603.     CMP.L    #127,D0
  604.     BGT.S    .out
  605.     MOVE    #4,CCR    ; Set "EQ"
  606. .out    RTS
  607.  
  608.  
  609. ;        ===========================
  610.  
  611. ;        OD STACK AND ASSOCIATED OPS
  612.  
  613. ;        ===========================
  614.  
  615. doBackDP
  616.     PUSH.L    A1
  617.     PUT.L    opDP,DP
  618.     ADDQ.B    #1,DPbacked-hbase(A4)
  619.     POP.L    A1
  620.     RTS
  621.  
  622. backDP    macrox
  623.     BSR    doBackDP
  624.     endm
  625.  
  626. markDP    macrox
  627.     GET.L    DP,opDP
  628.     endm
  629.  
  630. resetDP    macrox
  631.     GET.L    DP,opDP
  632.     CLR.W    ODsize(A0)
  633.     endm
  634.  
  635. noOpt    macrox
  636.     CLR.W    OD-hbase(A4)
  637.     endm
  638.  
  639.  
  640. upOD    macrox
  641.     SUBI    #ODsize,A0
  642.     endm
  643.  
  644. downOD    macrox
  645.     ADDI    #ODsize,A0
  646.     endm
  647.  
  648. UseODsrc    macrox
  649.     bsr    doUseODsrc
  650.     endm
  651.  
  652.  
  653. OD    byte    ODsize
  654.     align
  655.  
  656. ODnew    byte    ODsize    ; Used in generating new descriptors
  657.     align
  658. ODsav    byte    ODsize    ; Copy of OD for use here
  659.     align        ; - saved over possible , and w,
  660. ODprev    byte    ODsize
  661.     align
  662. OD2back    byte    ODsize
  663.     align
  664. OD3back    byte    ODsize
  665.     align
  666. OD4back    byte    ODsize
  667.     align
  668. ODdummy    byte    ODsize
  669.     align
  670.  
  671.     dc.w    0    ; So if we do DownOD we don't get a valid desc
  672.  
  673. ODreg    byte    ODsize    ; Used for intermediate temporary registers
  674.     align
  675. ODsrc    byte    ODsize    ; Used for temp source e.g. stack
  676.     align
  677. ODpmSrc    byte    ODsize    ; Used for stack source for arithmetic
  678.     align
  679. ODdst    byte    ODsize    ; Used for temp destination
  680.     align
  681. XLOD    byte    ODsize    ; Used for ExtraLocals area
  682.     align
  683. tmpOD    byte    ODsize    ; Used for anything else at the top level
  684.     align
  685.  
  686. ODstkSize    equ    8    ; Max of 8 temp descriptors
  687.  
  688.     byte    (ODsize + 4) * ODstkSize
  689. ODstk
  690.  
  691. ODsp    long
  692.  
  693.  
  694. MoveDesc
  695.     move.l    (a0),(a1)
  696.     move.l    4(a0),4(a1)
  697.     move.l    8(a0),8(a1)
  698.     move.l    12(a0),12(a1)
  699.     move.l    16(a0),16(a1)
  700.     rts
  701.  
  702. doUseODsrc    lea    ODsrc,a0    ; Then fall thru to ClearOD
  703. ClearOD
  704. ClrOD
  705.     clr.l    (a0)
  706.     clr.l    4(a0)
  707.     clr.l    8(a0)
  708.     clr.l    12(a0)
  709.     clr.l    16(a0)
  710.     move.b    #1,opind
  711.     move.b    #Lcode,opSize
  712.     rts
  713.  
  714. ExgOD
  715.     MOVEM.L    A0-A1,-(A6)
  716.     MOVEQ    #4,D0
  717. .exdLp    MOVE.L    (A1),D1
  718.     MOVE.L    (A0),(A1)+
  719.     MOVE.L    D1,(A0)+
  720.     DBRA    D0,.exdLp
  721.     MOVEM.L    (A6)+,A0-A1
  722.     RTS
  723.  
  724.  
  725. SaveOD
  726.     LEA    OD,A0
  727.     LEA    ODsav,A1
  728.     BSR.S    MoveDesc
  729.  
  730. ; Now fall through to InitODs
  731.  
  732. InitODs
  733.     LEA    ODsrc,A0
  734.     bsr    ClearOD
  735.     MOVE.B    #stkPop,opMode
  736.     MOVE.B    #Lcode,opSize
  737.  
  738.     LEA    ODnew,A0
  739.     bsr    ClearOD
  740.     MOVE.B    #stkPop,opMode
  741.     PUSH.L    A1    ; Save A1 over GET - needed in places
  742.     get.L    DP,opDP
  743.     POP.L    A1
  744.     RTS
  745.  
  746. ; PushOD pushes a new OD value.  The new descriptor value is in ODnew, and
  747. ; goes to OD.  The previous descriptor will have been saved in ODsav by a
  748. ; call to SaveOD, and goes to ODprev.  The previous value of ODprev
  749. ; goes to OD2back, and so on.  Keeping all these allows us to optimize
  750. ; sequences such as
  751. ;     <value> 99 > IF ...
  752. ; ODnew is not changed, and A0 is left pointing there.
  753.  
  754. PushOD
  755.     GET.L    optq,D0
  756.     BEQ.S    .noOpt
  757.     LEA    OD3back,A0
  758.     LEA    OD4back,A1
  759.     BSR.S    MoveDesc
  760.     LEA    OD2back,A0
  761.     LEA    OD3back,A1
  762.     BSR.S    MoveDesc
  763.     LEA    ODprev,A0
  764.     LEA    OD2back,A1
  765.     BSR.S    MoveDesc
  766.     LEA    ODsav,A0
  767.     LEA    ODprev,A1
  768.     BSR.S    MoveDesc
  769.     LEA    ODnew,A0
  770.     LEA    OD,A1
  771.     bra.s    MoveDesc
  772.  
  773. .noOpt    CLR.W    OD-hbase(A4)
  774.     RTS
  775.  
  776. PopOD
  777.     LEA    ODsav,A0
  778.     LEA    ODnew,A1
  779.     BSR.S    MoveDesc    ; ODsav -> ODnew
  780.     LEA    ODprev,A0
  781.     LEA    OD,A1
  782.     BSR.S    MoveDesc
  783.     LEA    ODsav,A1
  784.     BSR.S    MoveDesc    ; ODprev -> OD and ODsav
  785.     LEA    OD2back,A0
  786.     LEA    ODprev,A1
  787.     BSR.S    MoveDesc    ; OD2back -> ODprev
  788.     LEA    OD3back,A0
  789.     LEA    OD2back,A1
  790.     BSR.S    MoveDesc    ; OD3back -> OD2back
  791.     LEA    OD4back,A0
  792.     LEA    OD3back,A1
  793.     BSR.S    MoveDesc    ; OD4back -> OD3back
  794.     CLR.W    (A0)    ; Invalidate OD4back
  795.     LEA    ODnew,A0
  796.     RTS
  797.  
  798. PopODts    ; As for PopOD but saves the ts and flags fields from the
  799.     ; descriptor pointed to by A0, and sets it into the
  800.     ; corresponding fields of ODnew.  Uses D0-1.
  801.     MOVE.W    (A0),D0
  802.     MOVE.B    opFlags,D1
  803.     BSR.S    PopOD
  804.     MOVE.W    D0,(A0)
  805.     MOVE.B    D1,opFlags
  806.     RTS
  807.  
  808. DropOD    ; As for PopOD but leaved ODnew unchanged.  The main effect
  809.     ; is thus to drop the ODsav descriptor.
  810.     LEA    ODprev,A0
  811.     LEA    OD,A1
  812.     BSR.S    MoveDesc
  813.     LEA    ODsav,A1
  814.     BSR.S    MoveDesc    ; ODprev -> OD and ODsav
  815.     LEA    OD2back,A0
  816.     LEA    ODprev,A1
  817.     BSR.S    MoveDesc    ; OD2back -> ODprev
  818.     LEA    OD3back,A0
  819.     LEA    OD2back,A1
  820.     BSR.S    MoveDesc    ; OD3back -> OD2back
  821.     LEA    OD4back,A0
  822.     LEA    OD3back,A1
  823.     BSR.S    MoveDesc    ; OD4back -> OD3back
  824.     CLR.W    (A0)    ; Invalidate OD4back
  825.     LEA    ODnew,A0
  826.     RTS
  827.  
  828. NewOD    ; Allocates a new desc off the OD stack.  Copies the
  829.     ; A0 desc into the new one.  Leaves A0 pointing to the
  830.     ; new one.
  831.  
  832.     SUB.W    #ODsize+4,ODsp-hbase(A4)
  833.     cmpi.w    #-( ODStkSize * (ODsize+4) ),ODsp-hbase(a4)
  834.     ble    .odOvfl
  835.     PUSH.L    A1
  836.     LEA    ODstk,A1
  837.     ADD.W    ODsp,A1
  838.     MOVE.L    A0,ODsize(A1)
  839.     BSR    MoveDesc
  840.     MOVE.L    A1,A0
  841.     POP.L    A1
  842.     RTS
  843.  
  844. NewClrOD    ; Allocates a new desc off the OD stack and clears it
  845.     ; (except for the opind field, which is set to 1, and the
  846.     ; opSize field which is set to Lcode).
  847.     ; Leaves A0 pointing to the new one.
  848.  
  849.     sub.w    #ODsize+4,ODsp-hbase(A4)
  850.     cmpi.w    #-( ODStkSize * (ODsize+4) ),ODsp-hbase(a4)
  851.     ble.s    .odOvfl
  852.     push.l    a1
  853.     lea    ODstk,a1
  854.     add.w    ODsp,a1
  855.     move.l    a0,ODsize(a1)
  856.     move.l    a1,a0
  857.     pop.l    a1
  858.     bra    ClearOD
  859.  
  860. ReleaseOD
  861.     LEA    ODstk,A0
  862.     ADD.W    ODsp,A0
  863.     MOVE.L    ODsize(A0),A0
  864.     ADD.W    #ODsize+4,ODsp-hbase(A4)
  865.     BGT.S    .odUndfl
  866.     RTS
  867.  
  868. .odUndfl        ; OD stack underflow
  869.     dc.w    $FFE5    ; Make sure we don't continue execution!
  870.     clr.w    ODsp-hbase(a4)
  871.  
  872. .odOvfl    dc.w    $FFE6    ; OD stack overflow
  873.  
  874.  
  875. ; CmpAddrs compares the A0 and A1 descriptors, and returns with CC "equal" if
  876. ; the addresses are the same - defined as the mode, base reg, index reg,
  877. ; displacement, size and indirection count all being equal.
  878.  
  879. CmpAddrs    move.b    opInd,d0
  880.     cmp.b    opInd(a1),d0
  881.     bne.s    .caRtn
  882.     move.b    opBreg,d0
  883.     cmp.b    opBreg(a1),d0
  884.     bne.s    .caRtn
  885.     move.b    opMode,d0
  886.     cmp.b    opMode(a1),d0
  887.     bne.s    .caRtn
  888.     cmp.b    #mdDn,d0    ; If all equal so far, and mode
  889.     beq.s    .caRtn    ;  is Dn or An, everything else is
  890.     cmp.b    #mdAn,d0    ;  irrelevant so we return "equal"
  891.     beq.s    .caRtn
  892.     move.l    opDispl,d0
  893.     cmp.l    opDispl(a1),d0
  894.     bne.s    .caRtn
  895.     move.b    opXreg,d0
  896.     cmp.b    opXreg(a1),d0
  897.     bne.s    .caRtn
  898.     move.b    opSize,d0
  899.     cmp.b    opSize(a1),d0
  900. .caRtn    rts
  901.  
  902. doODvalid
  903.     LEA    ODsav,A0
  904.     LEA    OD,A1
  905.     BRA    MoveDesc
  906.  
  907. ODvalid    macrox
  908.     BSR    doODvalid
  909.     endm
  910.  
  911.  
  912. ; ChkOpt checks OD to see if any optimization may be possible.
  913. ; If there is, it leaves the type field in D1 (lo byte), the subtype
  914. ; in D2, and returns with the CC NE.  Note that garbage may be
  915. ; in the high bytes of D1 and D2.  D3 is used, and D0 is not altered.
  916. ; If no optimization is possible, ChkOpt returns with the CC EQ, and
  917. ; only D1 clobbered.
  918.  
  919. ChkOpt    MOVE.W    OD,D1
  920.     BEQ.S    .retn
  921. ;    TST.L    optq
  922. ;    BEQ.S    .retn
  923.     MOVE.L    D1,D2    ; Subtype field to D2
  924.     LSR.W    #8,D1    ; Type field in low byte of D1
  925.     MOVEQ    #1,D3    ; Set CC non-zero
  926. .retn    RTS
  927.  
  928.  
  929. ;        ================================
  930.  
  931. ;        LOW LEVEL INSTRUCTION GENERATION
  932.  
  933. ;        ================================
  934.  
  935.  
  936. ; CompMOVEQ compiles a MOVEQ of the number in D1 to the register
  937. ; designated by D0.  Uses D0.
  938.  
  939. CompMOVEQ
  940.     ANDI.W    #$FF,D0
  941.     ANDI.W    #$FF,D1
  942.     ROR.W    #7,D0
  943.     OR.W    D1,D0
  944.     ORI.W    #$7000,D0
  945.     PUSH.L    D0
  946.     JSR    wcomma
  947.     RTS
  948.  
  949.  
  950. ; EAbits ORs in the effective address bits to the opcode in D0, according
  951. ; to the descriptor pointed to by A0.  Uses D1.  A0 is saved.
  952.  
  953.     dc.b    $1E,$16,$26
  954. StkCodes
  955. eaModes    dc.b    $28,$30,$39,$3C,0,$08,$3A,$3B
  956.     align
  957.  
  958. EAbits    MOVE.B    opMode,D1
  959.     EXT.W    D1
  960.     TST.L    opDispl    ; If displ field is zero,
  961.     BEQ.S    .eazd    ;  check for base-displ mode
  962. .ea1    OR.B    eaModes(D1.W),D0
  963.     TST.W    D1
  964.     BMI.S    .eaOut
  965.     CMP.B    #mdAbs,opMode
  966.     BEQ.S    .eaAbs
  967.     cmp.b    #mdPC,opMode
  968.     beq.s    .eaOut
  969.     cmp.b    #mdPCX,opMode
  970.     beq.s    .eaOut
  971. .ea2    MOVE.B    opReg,D1
  972.     AND.B    #7,D1
  973.     OR.B    D1,D0    ; Put in base reg / operand reg
  974. .eaOut    RTS
  975.  
  976. .eazd    CMP.B    #mdBD,D1    ; If BD mode with zero displ,
  977.     BNE.S    .ea1    ;  we change to reg indirect
  978.     OR.W    #$10,D0
  979.     BRA.S    .ea2
  980.  
  981. .eaAbs    MOVE.L    opLit,D1
  982.     EXG    D0,D1
  983.     BSR    WdChk
  984.     EXG    D0,D1
  985.     SEQ    opShort
  986.     BNE.S    .eaOut
  987.     BCLR    #0,D0
  988.     RTS
  989.  
  990.  
  991. ; CompLit compiles a literal field.  The value is in D0.
  992.  
  993. compLit    PUSH.L    D0
  994.     CMP.B    #Lcode,opSize
  995.     BNE.S    .clwc
  996.     JSR    comma
  997.     RTS
  998.  
  999. .clwc    JSR    wcomma
  1000.     RTS
  1001.  
  1002.  
  1003. ; CompExt compiles the extension fields (if any) according to the
  1004. ; descriptor pointed to by A0.  Regs are saved.
  1005.  
  1006. CompExt
  1007.     movem.l    d0-d1,-(a6)
  1008.     cmp.b    #mdLit,opMode
  1009.     beq    .exLit
  1010.     cmp.b    #mdAbs,opMode
  1011.     beq.s    .exAbs
  1012.     cmp.b    #mdBD,opMode
  1013.     beq.s    .exBD
  1014.     cmp.b    #mdPC,opMode
  1015.     beq.s    .exPC
  1016.     cmp.b    #mdX,opMode
  1017.     beq.s    .exX
  1018.     cmp.b    #mdPCX,opMode
  1019.     bne.s    .exNone
  1020.  
  1021. ; Index mode.  We assume that the displacement can fit in 8 bits.  The caller
  1022. ; should ensure this, as if the displ is too large, an extra instruction
  1023. ; (LEA) needs to be generated.
  1024.  
  1025. .exX    MOVEQ    #0,D0
  1026.     MOVE.B    opXreg,D0
  1027.     bclr    #6,d0    ; Set appropriate bit if index is An
  1028.     beq.s    .exX1
  1029.     bset    #3,d0
  1030. .exX1    ROR.W    #4,D0
  1031.     OR.W    #$0800,D0    ; Note: we assume the index is always long
  1032.     move.l    opDispl,d1
  1033.     cmp.b    #mdPCX,opMode
  1034.     bne.s    .exX2
  1035.     push.l    a1
  1036.     get.L    dp,d1
  1037.     sub.l    opAddr,d1
  1038.     neg.l    d1
  1039.     pop.l    a1
  1040. .exX2    or.b    d1,d0
  1041.     BRA.S    .ex1
  1042.  
  1043. .exBD    MOVE.L    opDispl,D0
  1044.     BEQ.S    .exNone
  1045.  
  1046. .ex1    PUSH.L    D0
  1047. .ex2    JSR    wcomma
  1048. .exNone
  1049. .exOut    movem.l    (a6)+,d0-d1
  1050.     rts
  1051.  
  1052. .exAbs    PUSH.L    opLit
  1053.     TST.B    opShort
  1054.     BNE.S    .ex2
  1055.     JSR    comma
  1056.     bra.s    .exOut
  1057.     
  1058. .exLit    MOVE.L    opLit,D0
  1059.     bsr    CompLit
  1060.     bra.s    .exOut
  1061.  
  1062. .exPC    push.l    a1
  1063.     get.L    dp,d0
  1064.     sub.l    opAddr,d0
  1065.     neg.l    d0
  1066.     pop.l    a1
  1067.     bra.s    .ex1
  1068.  
  1069.  
  1070. GetSize
  1071.     MOVEQ    #0,D1
  1072.     MOVE.B    opSize,D1
  1073.     ROR.B    #2,D1
  1074.     OR.W    D1,D0
  1075.     RTS
  1076.  
  1077. GetReg
  1078.     MOVEQ    #0,D1
  1079.     MOVE.B    opToFrom,D1
  1080.     ROR.W    #7,D1
  1081.     OR.W    D1,D0
  1082.     RTS
  1083.  
  1084.  
  1085. ; CompMOp compiles an operation with an ea, according to the descriptor
  1086. ; pointed to by A0.  The desired opcode is in D0.  If the register field
  1087. ; is OK already or is irrelevant, enter at CompMOp1.  Likewise if both the
  1088. ; reg and size fields are OK or irrelevant, enter at CompMop2.
  1089. ; A0 is saved.
  1090.  
  1091. CompMOp    BSR.S    GetReg
  1092. CompMop1
  1093.     BSR.S    GetSize
  1094. CompMop2
  1095.     BSR    EAbits
  1096. CompMOp3
  1097.     PUSH.L    D0
  1098.     JSR    wcomma
  1099.     BRA.S    CompExt
  1100.  
  1101.  
  1102. ; CompLEA compiles an LEA (what else?).  The opind field and flags field are ignored
  1103. ; - they should already have been looked after.
  1104. ;    D0 = A reg no.
  1105.  
  1106. CompLEA
  1107.     and.w    #7,d0
  1108.     tst.l    opDispl
  1109.     beq.s    .clzd
  1110.  
  1111. .cl1    move.w    #$41C0,D1    ; LEA  addr,An
  1112. .cl2    ror.w    #7,D0
  1113.     or.w    D1,D0
  1114.     bra.s    CompMop2
  1115.  
  1116. .clzd    cmp.b    #mdX,opMode    ; If zero displ, maybe we can optimize.
  1117.     beq.s    .clX    ; Handle index mode separately
  1118.     cmp.b    #mdBD,opMode
  1119.     bne.s    .cl1
  1120.     move.b    opBreg,d1    ; BD mode. Is dest reg same as base?
  1121.     and.b    #7,d1
  1122.     cmp.b    d0,d1
  1123.     bne.s    .cl1    ; No
  1124.     rts        ; Yes: We don't need to compile anything!
  1125.  
  1126. .clX    MOVE.B    opBreg,D1    ; Index mode with zero displ.
  1127.     AND.B    #7,D1
  1128.     CMP.B    D1,D0    ; Same base and dest reg?
  1129.     BNE.S    .cl1    ; No
  1130.     MOVE.W    #$D1C0,D1    ; Yes.  Substitute  ADDA  Dn,An
  1131.     MOVE.B    #mdDn,opMode
  1132.     MOVE.B    opXreg,opReg
  1133.     BRA.S    .cl2
  1134.  
  1135. ; CompPOPReg compiles a  POP.L Dn/An  where n is in D0 on entry.
  1136. ; Uses D1.
  1137.  
  1138. CompPOPReg
  1139.     MOVE.W    D0,D1
  1140.     AND.W    #AnReg,D1
  1141.     AND.W    #7,D0
  1142.     ROR.W    #7,D0
  1143.     OR.W    D1,D0
  1144.     OR    xpopD0,D0
  1145.     PUSH.L    D0
  1146.     JSR    wcomma
  1147.     RTS
  1148.  
  1149. ; CompMOVEM compiles a MOVEM.
  1150. ; Entered with:
  1151. ;    D0 = ea bits (this routine ORs in the right opcode)
  1152. ;     D1 = mask (not reversed yet for predecrement mode)
  1153. ;     D2 (lo byte) = flags:
  1154. ;       bit 0:    direction (0 = regs to mem, 1 = mem to regs)
  1155. ;       bit 1:    1 = predecrement  0 = everything else.
  1156. ;
  1157. ;    A0 -> memory operand descriptor, if an extension needs to be compiled
  1158. ;    (i.e. mode isn't predecrement or postincrement).  Otherwise ignored.
  1159.  
  1160. ; Preserves all D regs.
  1161.  
  1162. CompMOVEM
  1163.     loc
  1164.     movem.l    d0-d3,-(a6)    ; Save regs
  1165.     and.l    #$FFFF,d1    ; Mask out any garbage in high word of D1
  1166.     beq.s    .out    ; If no regs to be moved, don't compile
  1167.             ;  anything
  1168.     bsr    LowBit    ; Check if only 1 reg to be moved
  1169.     blt.s    .oneReg
  1170.     move.l    (a6),d0    ; Recover D0
  1171.     btst    #1,d2
  1172.     bne.s    .predec
  1173.  
  1174. .cmm1            ; All modes except predecrement.
  1175.     or.w    #$48C0,d0    ; MOVEM op to D0
  1176.     btst    #0,d2    ; Set Direction bit appropriately
  1177.     beq.s    .cmm2
  1178.     bset    #10,d0
  1179. .cmm2    swap    d0
  1180.     move.w    d1,d0
  1181.     push.l    d0
  1182.     jsr    comma    ; Compile the op
  1183.  
  1184. .cmmExt    btst    #1,d2    ; Now check if we need to compile an extension
  1185.     bne.s    .out    ; Not if predecrement
  1186.     move.l    (a6),d0    ; Recover ea bits in D0
  1187.     and.b    #$38,d0
  1188.     cmp.b    #$18,d0
  1189.     beq.s    .out    ; Not if postincrement either
  1190.     bsr    CompExt    ; Otherwise compile ext - we hope A0 is valid!
  1191. .out    movem.l    (a6)+,d0-d3    ; Restore regs
  1192.     rts        ;  and out.
  1193.  
  1194. .predec            ; Predecrement mode.  We need to reverse
  1195.     exg    d0,d1    ; the mask
  1196.     bsr    BitReverse
  1197.     exg    d0,d1
  1198.     bra.s    .cmm1    ; Then proceed as above.
  1199.  
  1200. .oneReg
  1201.     move    d0,d1    ; Move bit# to D1 (don't need mask now)
  1202.     move.l    (a6),d0    ; Recover D0
  1203.     btst    #0,d2
  1204.     beq.s    .1r2m
  1205.     cmp.b    #7,d1
  1206.     ble.s    .1r1
  1207.     subq.b    #8,d1
  1208.     or.w    #40,d0
  1209. .1r1    ror.w    #7,d1
  1210. .1rCmpl    or.w    d1,d0
  1211.     or.w    #$2000,d0
  1212.     push.l    d0
  1213.     jsr    wcomma
  1214.     bra.s    .out
  1215.  
  1216. .1r2m    move    d0,d3
  1217.     and.w    #7,d0
  1218.     lsl    #6,d0
  1219.     and    #$38,d3
  1220.     or    d3,d0
  1221.     lsl    #3,d0
  1222.     cmp.b    #7,d1
  1223.     ble.s    .1rCmpl
  1224.     subq.b    #8,d1
  1225.     or.w    #8,d0
  1226.     bra.s    .1rCmpl
  1227.  
  1228.  
  1229. ; RevCond reverses the selected condition for a branch; i.e. there are two
  1230. ; operands whose positions are to be reversed.  We assume that CMPdesc points
  1231. ; to the comparison descriptor.
  1232.  
  1233. RevCond    PUSH.L    A0
  1234.     move.l    CMPdesc,a0
  1235.     CMP.B    #7,opSubType    ; No action if code = EQ
  1236.     BEQ.S    .getout
  1237.     CMP.B    #6,opSubType    ; or NE
  1238.     BEQ.S    .getout
  1239.     EOR.B    #3,RCond-hbase(A4)    ; Otherwise we flip the two low bits.
  1240. .getout    POP.L    A0
  1241.     RTS
  1242.  
  1243.  
  1244. ; ViaD compiles a MOVE sequence to use Dn or A0 as intermediate storage.
  1245. ; This is normally to lengthen the operand.  We use A0 if we need to
  1246. ; sign-extend from word to long, since this occurs automatically in the
  1247. ; A registers.
  1248. ;
  1249. ; A0 -> source descriptor
  1250. ; A1 -> destination descriptor
  1251. ;
  1252. ; Both are preserved.
  1253.  
  1254. direct    byte
  1255. byte2L    byte
  1256. clearD    byte
  1257.     align
  1258.  
  1259. ViaD    MOVEQ    #2,D0
  1260.     CLR.B    direct-hbase(A4)
  1261.     CLR.B    byte2L-hbase(A4)
  1262.     BTST    #flExt,opFlags    ; Sign-extend?
  1263.     BEQ.S    .vdD    ; No - use D reg
  1264.     tst.b    svInhibitClr-hbase(a4) ; Inhibit clear/extend?
  1265.     bne.s    .vdD    ; Yes - use D reg
  1266.     CMP.B    #Wcode,opSize    ; No - is it word to long?
  1267.     BEQ.S    .vdA    ; Yes - use A reg
  1268.     ST    byte2L-hbase(A4)    ; No, byte to long.  Remember that.
  1269.  
  1270. .vdD    sf    clearD-hbase(a4)    ; Use a D reg.
  1271.     cmp.b    #Lcode,opSize(A0)    ; Find out if we need to clear it first.
  1272.     beq.s    .vdd0    ; Don't need to clear reg if src
  1273.     btst    #flExt,opFlags(A0)    ;  is long, or if we're sign extending
  1274.     bne.s    .vdd0    ;  or if we're inhibiting the clear
  1275.     tst.b    svInhibitClr-hbase(a4)
  1276.     seq    clearD-hbase(a4)    ; Set flag true if clear needed
  1277.  
  1278. .vdd0    CMP.B    #mdDn,opMode(A1)    ; Is dest already a D reg?
  1279.     BNE.S    .vdd2    ; No
  1280.  
  1281. ; Dest is already a D reg.  We might be able to go directly to this as the
  1282. ; "temporary", and not move it anywhere at the end.
  1283. ; But first we need to check for one possible problem case - where we need
  1284. ; to clear the reg first, but the source is index mode, with the same index
  1285. ; reg as the dest D reg.
  1286.  
  1287.     move.b    opReg(a1),d1    ; Dest reg no to D1
  1288.     tst.b    clearD-hbase(a4)
  1289.     beq.s    .vdd1    ; If no clear, no problem
  1290.     cmp.b    #mdX,opMode(a0)
  1291.     bne.s    .vdd1    ; If source not index mode, no problem
  1292.     cmp.b    opXreg(a0),d1    ; Regs same?
  1293.     beq.s    .vdd2    ; YES - problem - don't go direct!
  1294.             
  1295. .vdd1    move.b    d1,d0    ; No problem.  Set "temp" reg number
  1296.     st    direct-hbase(A4)    ;  and set "direct" flag
  1297.  
  1298. .vdd2    PUSH.L    A1    ; Save dest desc pointer
  1299.     LEA    ODreg,A1    ; And use ODreg as desc for D reg
  1300.     MOVE.B    D0,opReg(A1)
  1301.     MOVE.B    #mdDn,opMode(A1)
  1302.     tst.b    clearD-hbase(a4)    ; Clear the reg?
  1303.     beq.s    .vd2    ; No
  1304.     MOVEQ    #0,D1    ; Yes
  1305.     BSR    CompMOVEQ    ; Generate MOVEQ to clear it
  1306.     BRA.S    .vd2
  1307.  
  1308. .vdA    PUSH.L    A1    ; Sign extension from word to long.
  1309.     cmp.b    #mdAn,opMode(a1)    ; Is dest already An?
  1310.     seq    direct-hbase(a4)    ; If so, go directly there
  1311.     beq.s    .vd2
  1312.     lea    ODreg,A1    ; Otherwise we use A0 as the
  1313.     clr.b    opReg(A1)    ; intermediate register.
  1314.     move.b    #mdAn,opMode(A1)
  1315.  
  1316. .vd2    MOVE.B    opSize(A0),opSize(A1)
  1317.     BSR.S    compMove    ; Compile the MOVE to Dn/An
  1318.     TST.B    byte2L-hbase(A4)    ; Extend from byte to long in Dn?
  1319.     BEQ.S    .vd3    ; Not if we didn't set the flag
  1320.     tst.b    svInhibitClr-hbase(a4)
  1321.     bne.s    .vd3    ; Or if we're inhibiting clear/extend
  1322.     MOVEQ    #0,D0    ; Yes, we'll do it.
  1323.     MOVE.B    opReg(A1),D0    ; Get reg #
  1324.     MOVE.L    D0,D1
  1325.     OR.W    #$4880,D0    ; EXT.W  Dn
  1326.     SWAP    D0
  1327.     MOVE.W    D1,D0
  1328.     OR.W    #$48C0,D0    ; EXT.L  Dn
  1329.     PUSH.L    D0
  1330.     JSR    comma
  1331.  
  1332. .vd3    POP.L    D0    ; Recover dest desc pointer
  1333.     PUSH.L    A0    ; Save A0
  1334.     MOVE.L    A1,A0    ; A0 -> intermediate desc ODreg
  1335.     MOVE.L    D0,A1    ; A1 -> original dest desc
  1336.     TST.B    direct-hbase(A4)    ; Did we go direct to the dest reg?
  1337.     BNE.S    .vdEnd    ; Yes - we're finished.
  1338.     MOVE.B    opSize(A1),opSize    ; Otherwise compile MOVE from
  1339.     BSR.S    compMove    ;  Dn/An to dest
  1340. .vdEnd    POP.L    A0    ; Restore A0
  1341.     RTS
  1342.  
  1343.  
  1344. ;    =========================
  1345.  
  1346. ;        COMPMOVE
  1347.  
  1348. ;    =========================
  1349.  
  1350. ; CompMOVE (surprise, surprise) compiles a MOVE.
  1351. ;
  1352. ; A0 -> source descriptor
  1353. ; A1 -> destination descriptor.
  1354.  
  1355. ; The operand lengths don't have to match - we generate any appropriate
  1356. ; extra instructions to sort things out.
  1357.  
  1358. compMOVE
  1359.     moveq    #0,d0
  1360.     moveq    #0,d1
  1361.     cmp.b    #mdLit,opMode(a0)
  1362.     beq    .mvLit    ; If source is literal, handle it
  1363.  
  1364. ; First we check if it's the address to be moved, not the operand.  This
  1365. ; only makes sense for some modes.  For modes mdAbs, mdLit, mdDn, mdAn
  1366. ; or the stack modes, we IGNORE the opind field.
  1367.  
  1368.     tst.b    opMode(a0)
  1369.     bmi.s    .mvFPck    ; Skip check if stack mode
  1370.     cmp.b    #mdX,opMode(a0)
  1371.     bls.s    .mvck
  1372.     cmp.b    #mdPC,opMode(a0)
  1373.     blo.s    .mvFPck    ; Or if mdAbs, mdLit, mdDn or mdAn
  1374.  
  1375. .mvck    TST.B    opind    ; Now here's the check.
  1376.     BEQ    .mvAddr    ; If opind=0, go move the address
  1377.  
  1378. .mvFPck    btst    #flFP,opFlags(a0)    ; If either operand is floating,
  1379.     bne    .mvFP    ;  call FP move routine
  1380.     btst    #flFP,opFlags(a1)
  1381.     beq.s    .mvsz
  1382.  
  1383. .mvFP    movem.l    a0/a1,-(a6)
  1384.     bsr    FPmove
  1385.     or.b    d0,FPdispflg-hbase(a4)
  1386.     bsr    chkFPdisp
  1387.     movem.l    (a6)+,a0/a1
  1388.     rts
  1389.  
  1390.  
  1391. MoveTbl    dc.w    $1000,$3000,$2000
  1392.  
  1393. LengthTable
  1394.     dc.b    1,2,4
  1395.     align
  1396.  
  1397. .mvsz    MOVE.B    opSize(A0),D0    ; Normal move.
  1398.     MOVE.B    opSize(A1),D1
  1399.     CMP.B    #Lcode,D1    ; If dst is not long
  1400.     BEQ.S    .mv0    ;  and the source is the stack
  1401.     TST.B    opMode(A0)    ;  then we have to go via a D reg.
  1402.     BMI    ViaD
  1403.  
  1404. .mv0    MOVE.B    LengthTable(D0.W),D0
  1405.     MOVE.B    LengthTable(D1.W),D1
  1406.     SUB.B    D1,D0
  1407.     BLT    ViaD
  1408.     BEQ.S    .mv2
  1409.     ADD.L    D0,opDispl(A0)
  1410. .mv1    MOVE.B    opSize(A1),opSize(A0)
  1411.  
  1412. .mv2    MOVEQ    #0,D0
  1413.     MOVE.B    opSize(A0),D0
  1414.     ADD.W    D0,D0
  1415.     MOVE.W    MoveTbl(D0.W),D0    ; Get right MOVE opcode
  1416.     BSR    EAbits    ; OR in source mode/reg
  1417.  
  1418.     PUSH.L    D0    ; Now we get the dest reg/mode  Save src
  1419.     EXG    A0,A1
  1420.     MOVEQ    #0,D0
  1421.     BSR    EAbits
  1422.     MOVE.L    D0,D1
  1423.     AND    #7,D0
  1424.     LSL    #6,D0
  1425.     AND    #$38,D1
  1426.     OR    D1,D0
  1427.     LSL    #3,D0    ; Get into right place
  1428.     OR.L    D0,(A6)    ; OR with src - final opcode in stk
  1429.     JSR    wcomma
  1430.     EXG    A0,A1
  1431.     BSR    CompExt    ; Compile source extension
  1432.     EXG    A0,A1
  1433.     BSR    CompExt    ; And destination extension
  1434.     EXG    A0,A1    ; Put A0 and A1 back to what they were
  1435.     RTS
  1436.  
  1437. ; Literal source.  We may be able to optimize.
  1438.  
  1439. .mvLit    move.l    opLit,d1
  1440.     move.l    d1,d0
  1441.     bsr    ByteChk
  1442.     bne    .mv1
  1443. ;    TST.B    opShort    ; Short?
  1444. ;    BEQ    .mv1    ; No - just compile literal mode src
  1445. ;    MOVE.L    opLit,D1    ; Yes.  Value to D1
  1446.     CMP.B    #mdDn,opMode(A1)    ; Is destination Dn?
  1447.     BNE.S    .mvLm    ; No
  1448.     MOVE.B    opReg(A1),D0    ; Yes.  Reg no to D0
  1449.     BRA    CompMOVEQ    ; compile MOVEQ, return
  1450.  
  1451. .mvLm    TST.L    D1    ; Memory or stack.  Is number zero?
  1452.     BEQ.S    mvZero    ; Yes
  1453.     MOVEQ    #2,D0    ; No
  1454.     BSR    CompMOVEQ    ; Compile MOVEQ  #nn,D2
  1455.     PUSH.L    A0    ; Save A0
  1456.     LEA    ODreg,A0    ; Change source to D2
  1457.     MOVE.B    #mdDn,opMode
  1458.     MOVE.B    #2,opReg
  1459.     BSR    .mv1    ; Compile MOVE
  1460.     POP.L    A0    ; Restore A0
  1461.     RTS
  1462.  
  1463. mvZero    EXG    A0,A1    ; Literal zero.  We compile a
  1464.     MOVE.W    xclrD0,D0    ; CLR instead.
  1465.     BSR    CompMOp1
  1466.     EXG    A0,A1
  1467.     RTS
  1468.  
  1469. .mvAddr            ; opind field is zero, so we need the
  1470.             ; address, not the operand.
  1471.     MOVEQ    #0,D0
  1472.     CMP.B    #mdAn,opMode(A1)
  1473.     BEQ.S    .mva1
  1474.     CMP.B    #mdBD,opMode
  1475.     BNE.S    .mva0
  1476.     TST.L    opDispl    ; If source is BD mode with zero displ,
  1477.     BEQ.S    .mva2    ;   we'll change it to An direct
  1478. .mva0    BSR    CompLEA    ; Compile  LEA  addr,A0
  1479.     PUSH.L    A0    ; Save src desc pointer
  1480.     LEA    ODreg,A0
  1481.     MOVE.B    #mdAn,opMode
  1482.     CLR.B    opReg
  1483.     MOVE.B    #Lcode,opSize
  1484.     BSR    .mvsz    ; Compile  MOVE  A0,dst
  1485.     POP.L    A0
  1486.     RTS
  1487.  
  1488. .mva1    MOVE.B    opReg(A1),D0
  1489.     BRA    CompLEA
  1490.  
  1491. .mva2    MOVE.B    #mdAn,opMode
  1492.     BRA    .mvsz
  1493.  
  1494.  
  1495. ;    =======================
  1496.  
  1497. ;        FPMOVE
  1498.  
  1499. ;    =======================
  1500.  
  1501. ; FPmove compiles a floating-point move.  A0 -> source desc, A1 -> dest desc.
  1502. ; leaves D0 non-zero if source was from FP heap (as it might need disposing).
  1503. ; If the destination requires a new heap location we compile the call to
  1504. ; create it straight away (since we need it right now!).
  1505.  
  1506. ; First, some utility routines:
  1507.  
  1508.     loc
  1509.  
  1510. .FPreg    moveq    #0,d1
  1511.     move.b    opReg(a1),d1
  1512. ;    move.b    #$80,d2
  1513. ;    lsr.b    d1,d2
  1514. ;    or.b    d2,d0
  1515.     lsl.w    #7,d1
  1516.     or.w    d1,d0
  1517.     rts
  1518.  
  1519. ToNewHeap
  1520.     bsr    CompFPnew
  1521.     push.l    a1
  1522.     exg    a0,a1
  1523.     bsr    newClrOD
  1524.     move.b    #mdBD,opMode
  1525.     move.b    #AnReg,opBreg
  1526.     move.b    #1,FPA-hbase(a4)
  1527.     clr.l    opDispl
  1528.     move.b    #1,opind
  1529.     move.b    #fbFP,opFlags
  1530.     exg    a0,a1
  1531.     bsr    FPmove1
  1532.     exg    a0,a1
  1533.     pop.l    a1
  1534.     move.b    #mdAn,opMode
  1535.     clr.b    opFlags
  1536.     bsr    compMove
  1537.     bra    releaseOD
  1538.  
  1539.  
  1540. UsePrevFPlit    byte
  1541.         align
  1542. CompFLit
  1543.     movem.l    a0/a1,-(a6)
  1544.     get.l    ptrFPULit,-(a6)
  1545.     bsr    CompJSRnoPush
  1546.     tst.b    usePrevFPlit-hbase(a4)
  1547.     bne.s    .cflPrev
  1548.     lea    svFPlit,a0
  1549. .cfl1    push.l    (a0)+
  1550.     jsr    comma
  1551.     push.l    (a0)+
  1552.     jsr    comma
  1553.     push.l    (a0)+
  1554.     jsr    comma
  1555.     movem.l    (a6)+,a0/a1
  1556.     clr.b    FPA-hbase(a4)    ; Destination operand must use A0 since
  1557.     rts        ;  literal will be addressed via A1
  1558.  
  1559. .cflPrev    sf    usePrevFPlit-hbase(a4)
  1560.     lea    prevFPlit,a0
  1561.     bra.s    .cfl1
  1562.  
  1563.  
  1564. FspecChk
  1565.     btst    #flLit,opFlags    ; Is operand a floating literal?
  1566.     beq.s    .fsChkCR
  1567.     bsr    CompFLit    ; Yes.  Compile literal sequence.
  1568.     bra.s    .fsOut
  1569.  
  1570. .fsChkCR
  1571.     btst    #flFCR,opFlags    ; Is it a constant ROM reference?
  1572.     beq.s    .fsOut    ; No
  1573.     move.l    #$F2005C00,d0    ;    fmoveCR    #0,FP0
  1574.     or.b    opRoffs,d0    ; OR in right CROM offset
  1575.     push.l    d0
  1576.     jsr    comma
  1577. .fsOut    rts
  1578.  
  1579.  
  1580. FPmove
  1581.     bsr.s    FspecChk    ; If source special, compile approp sequence
  1582. FPmove1    movem.l    d5-d7/a0/a1,-(a6)
  1583.     moveq    #0,d7
  1584.     btst    #flLit,opFlags
  1585.     sne    d5    ; If it was literal, flag this in D5
  1586.     cmp.b    #mdFPn,opMode(a0)
  1587.     beq    .op1reg
  1588.     cmp.b    #mdFPn,opMode(a1)
  1589.     beq    .memToReg
  1590.  
  1591. ; Neither is FPn.
  1592.  
  1593.     btst    #flFP,opFlags(a1)
  1594.     bne.s    .fpm0
  1595.     bsr.s    ToNewHeap
  1596.     bra    .fpmOut
  1597.  
  1598. .fpm0    move.b    FPA,d0
  1599.     btst    #flFP,opFlags    ; Is src floating data?
  1600.     bne.s    .op1fv
  1601.     moveq    #1,d7
  1602.     bsr    FetchToA    ; No. Get source addr to reqd A reg
  1603.     eor.b    #1,FPA-hbase(a4)    ; And use the "other" reg next time
  1604.     bra.s    .fpm1
  1605.  
  1606. .op1fv    tst.b    d5    ; Yes. Is source Literal?
  1607.     bne.s    .fpmLit
  1608.     bsr    compLEA    ; No.  Get source addr to reqd A reg.
  1609.         ; Note: can't use FetchToA here as FP flag bit is set which can cause 
  1610.         ; disasters. But we don't need to anyway.
  1611.  
  1612.     eor.b    #1,FPA-hbase(a4)    ; Use "other" reg next time
  1613.     bra.s    .fpm1
  1614.  
  1615. .fpmLit    clr.b    FPA-hbase(a4)    ; Literal source.  This uses A1 for the
  1616.             ; access, so dest addressing must use A0
  1617.             ; no matter what.
  1618. .fpm1    move.b    FPA,d0
  1619.     exg    a0,a1
  1620.     btst    #flFP,opFlags    ; Is dest floating data?
  1621.     bne.s    .op2fv
  1622.     bsr    FetchToA    ; No. Get dest addr to reqd A reg
  1623.     bra.s    .fpm2
  1624.  
  1625. .op2fv    bsr    compLEA    ; Yes. LEA dest addr to reqd A reg
  1626. .fpm2    exg    a0,a1
  1627.     tst.b    FPA-hbase(a4)    ; If src uses A1, we use the
  1628.     beq.s    .fpmA1A0    ;  other move sequence (A1 src, A0 dest).
  1629.     tst.b    d5
  1630.     bne.s    .fpmA1A0
  1631.     compopl    xFPmove    ;    movem.l    (a0),d0-d2
  1632.     compopl    xFPmove+4    ;    movem.l    d0-d2,(a1)
  1633.     bra.s    .fpmOut
  1634.  
  1635. .fpmA1A0    compopl    xFPmove2    ;    movem.l    (a1),d0-d2
  1636.     compopl    xFPmove2+4    ;    movem.l    d0-d2,(a0)
  1637.  
  1638. .fpmOut    move.l    d7,d0    ; Return "heap to dispose" flag in D0
  1639.     and.b    #fbLit,d5    ; Restore Literal flag in src descriptor
  1640.     or.b    d5,opFlags
  1641.     movem.l    (a6)+,d5-d7/a0/a1
  1642.     rts
  1643.  
  1644. .op1reg    cmp.b    #mdFPn,opMode(a1)
  1645.     bne.s    .regToMem
  1646.     moveq    #0,d0
  1647.  
  1648. ; Move reg to reg.
  1649.  
  1650.     move.b    opReg,d0
  1651.     cmp.b    opReg(a1),d0
  1652.     beq.s    .fpmOut    ; If the same one, get out without compiling
  1653.             ;  anything
  1654.     lsl.w    #3,d0
  1655.     or.b    opReg(a1),d0
  1656.     lsl.w    #7,d0
  1657.     swap    d0
  1658.     move.w    #$F200,d0    ; Compile:  fmove.x  FPn,FPm
  1659.     swap    d0
  1660.     push.l    d0
  1661.     jsr    comma
  1662.     bra.s    .fpmOut
  1663.  
  1664. .regToMem
  1665.     btst    #flFP,opFlags(a1)
  1666.     bne.s    .regToFv
  1667.     bsr    ToNewHeap
  1668.     bra    .fpmOut
  1669.  
  1670. .regToFv        ; Compile fmove.x  FPn,<ea>
  1671.     exg    a0,a1
  1672.     move.w    #$F200,d0
  1673.     bsr    EAbits
  1674.     swap    d0
  1675.     move.w    #$6800,d0
  1676.     bsr.s    .FPreg
  1677.     push.l    d0
  1678.     bsr    comma
  1679.     bsr    CompExt
  1680.     exg    a0,a1
  1681.     bra.s    .fpmOut
  1682.  
  1683. .memToReg
  1684.     btst    #flFP,opFlags(a0)    ; Is src a floating value/constant/literal?
  1685.     bne.s    .FVtoReg    ; Yes
  1686.     moveq    #1,d7    ; No - there will be heap to dispose
  1687.     move.b    FPA,d0
  1688.     or.b    #1,FPA-hbase(a4)
  1689.     move.b    d0,d6
  1690.     and.b    #7,d6
  1691.     bsr    FetchToA    ;    move.l    <ea>,An
  1692.     move.w    #$F210,d0    ;    fmove.x    (An),FPn
  1693.     or.b    d6,d0
  1694.     swap    d0
  1695.     move.w    #$4800,d0
  1696.     bsr.s    .FPreg
  1697.     push.l    d0
  1698.     bsr    comma
  1699.     bra.s    .fpmOut
  1700.  
  1701. .FVtoReg
  1702.  
  1703. ; Compile fmovem  <ea>,FPn
  1704.  
  1705. .fv2r0    move.w    #$F200,d0
  1706.     bsr    EAbits
  1707. .fv2r1    swap    d0
  1708.     move.w    #$4800,d0
  1709.     bsr.s    .FPreg
  1710.     push.l    d0
  1711.     bsr    comma
  1712.     bsr    CompExt
  1713.     bra.s    .fpmOut
  1714.  
  1715. ;.fLit2r    bsr    CompFLit
  1716. ;    bsr    newClrOD
  1717. ;    addq    #1,d5
  1718. ;    move.b    #AnReg+1,opBreg
  1719. ;    bra.s    .fv2r0
  1720.  
  1721.  
  1722. ;        ===================
  1723.  
  1724. ; CompMoveToFPn compiles a move from some <ea> given by the A0 desc, to
  1725. ; FPn where n is in D0.
  1726.  
  1727. CompMoveToFPn
  1728.     movem.l    d0/a0/a1,-(a6)
  1729.     bsr    newOD
  1730.     moveq    #0,d0
  1731.     bsr    LoadBase
  1732.     exg    a0,a1
  1733.     bsr    newClrOD
  1734.     move.b    #mdFPn,opMode
  1735.     move.b    #fbFP,opFlags
  1736.     pop.l    d0
  1737.     move.b    d0,opReg
  1738.     exg    a0,a1
  1739.     bsr    FPmove
  1740.     bsr    releaseOD
  1741.     bsr    releaseOD
  1742.     movem.l    (a6)+,a0/a1
  1743.     rts
  1744.  
  1745. ;        ===================
  1746.  
  1747. ; CompPopFPn compiles a pop from the stack to FPn, where n is in D0.
  1748. ; Note that what is actually in the stack is a pointer to the FP heap.
  1749. ; We assume the caller will handle the disposing of the heap, since it
  1750. ; may be better to put this after any compiled FP ops, to allow overlap.
  1751.  
  1752. CompPopFPn
  1753.     movem.l    a0/a1,-(a6)
  1754.     bsr    newClrOD
  1755.     move.b    #mdFPn,opMode
  1756.     move.b    #fbFP,opFlags
  1757.     move.b    d0,opReg
  1758.     move.l    a0,a1
  1759.     bsr    newClrOD
  1760.     move.b    #stkPop,opMode
  1761.     move.b    #1,opind
  1762.     bsr    FPmove
  1763.     bsr    releaseOD
  1764.     bsr    releaseOD
  1765.     movem.l    (a6)+,a0/a1
  1766.     rts
  1767.  
  1768.  
  1769. ;    =======================
  1770.  
  1771. ;        LOADBASE
  1772.  
  1773. ;    =======================
  1774.  
  1775. ; Loadbase is called before we compile any op referencing memory.
  1776. ; A0 must be pointing to the operand descriptor, and D0 indicates
  1777. ; which A reg should be used as a temporary for the operand address,
  1778. ; if necessary.
  1779. ; Loadbase compiles any necessary preliminary ops to ensure the data is
  1780. ; properly addressible, and modifies the descriptor appropriately.  It's
  1781. ; the caller's job to create a temp descriptor for this purpose, if the
  1782. ; original descriptor isn't to be clobbered.
  1783.  
  1784. ; First we have some utility routines needed by LoadBase.
  1785.  
  1786. StoreFlg    byte    ; Set true if this is a store op, so we
  1787.         ; don't generate a PC-relative store (illegal
  1788.         ; on 68000).
  1789. VirtBase    byte
  1790. LBsavFlgs    byte    ; Saves flags byte (we clear FP bit and need to restore it)
  1791.     align
  1792.  
  1793. SetupOD
  1794.     move.b    #Lcode,opSize(a1)
  1795.     move.b    #1,opind(a1)
  1796.     clr.l    opDispl(a1)
  1797.     clr.b    opFlags(a1)
  1798.     move.b    opToFrom,D0
  1799.     bmi.s    .toStk
  1800.     btst    #6,d0
  1801.     bne.s    .An
  1802.     btst    #5,d0
  1803.     bne.s    .FPn
  1804.     move.b    #mdDn,opMode(a1)
  1805.     bra.s    .suRtn
  1806.  
  1807. .An    move.b    #mdAn,opMode(a1)
  1808.     bra.s    .and
  1809.  
  1810. .FPn    move.b    #mdFPn,opMode(a1)
  1811.     move.b    #fbFP,opFlags(a1)
  1812. .and    and.b    #7,d0
  1813.  
  1814. .suRtn    move.b    d0,opReg(A1)
  1815.     rts
  1816.  
  1817. .toStk    move.b    d0,opMode(a1)
  1818.     rts
  1819.  
  1820.     loc
  1821. .LEAfirst
  1822.     move.b    WhichA,d0
  1823.     bsr    CompLEA
  1824.     move.b    WhichA,d0
  1825.     rts
  1826.  
  1827. ; We call SetOpAddr to make sure the opAddr field of the A0 descriptor is
  1828. ; set up.  It usually will be, but there are a few situations when it won't.
  1829. ; If the mode isn't base-displacement, indexed or PC-rel, or if the base reg
  1830. ; isn't a3, a4 or a5, we put -1 in opAddr, which will maybe cause a trap if it
  1831. ; gets used.
  1832.  
  1833. SetOpAddr
  1834.     movem.l    d0/d1/a1,-(a6)    ; Save regs (what else?)
  1835.     cmp.b    #mdBD,opMode
  1836.     beq.s    .ckBreg
  1837.     cmp.b    #mdX,opMode
  1838.     beq.s    .ckBreg
  1839.     cmp.b    #mdPC,opMode
  1840.     beq.s    .soaOut
  1841.     cmp.b    #mdPCX,opMode
  1842.     beq.s    .soaOut
  1843.     bra.s    .noAddr
  1844.  
  1845. .ckBreg    move.b    opBreg,d0
  1846.     and.b    #7,d0
  1847.     cmp.b    #3,d0
  1848.     beq.s    .useLB
  1849.     cmp.b    #4,d0
  1850.     beq.s    .useHB
  1851.     cmp.b    #5,d0
  1852.     beq.s    .useMB
  1853.  
  1854. .noAddr    moveq    #-1,d1
  1855.     bra.s    .soaAdr
  1856.  
  1857. .useLB    move.l    a3,d1
  1858.     bra.s    .soaAdd
  1859.  
  1860. .useHB    move.l    savedA4,d1
  1861.     bra.s    .soaAdd
  1862.  
  1863. .useMB    get.L    MBcomp,d1
  1864.  
  1865. .soaAdd    add.l    opDispl,d1
  1866. .soaAdr    move.l    d1,opAddr
  1867. .soaOut    movem.l    (a6)+,d0/d1/a1
  1868.     rts
  1869.  
  1870. ;        ======================
  1871.  
  1872. LoadBase
  1873.     or.b    #AnReg,D0
  1874.     move.b    D0,WhichA-hbase(A4)
  1875.     move.b    opFlags,LBsavFlgs-hbase(a4)
  1876.     bclr    #flFP,opFlags    ; We don't handle floating operands here,
  1877.             ;  so we clear the FP bit so as not to
  1878.             ;  confuse CompMove.
  1879.     push.l    A1    ; Save A1
  1880.     tst.b    opMode    ; If addressed locn is stack,
  1881.     bpl.s    .lbsoa    ; we force opSize to Lcode (which it has
  1882.     cmp.b    #1,opind    ; to be anyway)
  1883.     bgt.s    .lbsoa
  1884.     move.b    #Lcode,opSize
  1885. .lbsoa    bsr.s    setOpAddr
  1886.     cmp.b    #mdX,opMode
  1887.     bhi    .lb1
  1888. ;    beq    .lbX    ; BD or index mode.
  1889.     tst.b    opBreg    ; Is base reg stack?
  1890.     bpl.s    .lb0    ; No
  1891.  
  1892.     moveq    #0,d0    ; Yes.  Compile pop to An
  1893.     move.b    WhichA,d0
  1894.     and.b    #7,d0
  1895.     ror.w    #7,d0
  1896.     or.w    xpopA0,d0
  1897.     push.l    d0
  1898.     jsr    wcomma
  1899.     move.b    WhichA,opBreg    ; and change base reg to An in desc.
  1900.     bra.s    .lbReal
  1901.  
  1902. .lb0    btst.b    #6,opBreg    ; Is base reg Dn?
  1903.     bne.s    .lbReal    ; No (must be An already)
  1904.     moveq    #0,d0    ; Yes.  Compile move to An
  1905.     move.b    WhichA,d0
  1906.     and.b    #7,d0
  1907.     ror.w    #7,d0
  1908.     or.b    opBreg,d0
  1909.     or.w    xMvD0A0,d0
  1910.     push.l    d0
  1911.     jsr    wcomma
  1912.     move.b    WhichA,opBreg    ; and change base reg to An in desc.
  1913.  
  1914. .lbReal    move.l    opDispl,d0    ; Base reg is now An.  We now need to make
  1915.     move.b    opBreg,d1    ;  sure the base/displ in desc is "real".
  1916.     bclr    #6,d1
  1917.     move.b    d1,VirtBase-hbase(a4)
  1918.     move.l    opAddr,d2
  1919.     bsr    GetRealBase
  1920.     bne.s    .lbFar    ; If displ won't fit in 16 bits, special 
  1921.             ;  treatment
  1922.     cmp.b    #mdX,opMode
  1923.     bne.s    .lbOK
  1924.     bsr    ByteChk
  1925.     bne.s    .lbFar    ; Or for index mode, it's 8 bits.
  1926.  
  1927. .lbOK    move.l    d0,opDispl    ; Adjust descriptor: set real displacement
  1928.     bset    #6,d1    ; Final An number in d1. Set AnReg bit for 
  1929.             ;  desc
  1930.     move.b    d1,opBreg    ; The displ is in 16-bit range from base
  1931.     bra    .lb1
  1932.  
  1933. .lbFar            ; The displ is too big for a single 
  1934.             ;  instruction.
  1935.     move.l    d0,opDispl    ; Adjust descriptor: set real displacement
  1936.     bset    #6,d1    ; Final An number in d1. Set AnReg bit for desc
  1937.     move.b    d1,opBreg    ; Set base reg field in descriptor
  1938.             ; Now we work out how to handle this:
  1939.     move.l    opAddr,d0    ; First we check if PC-rel will work
  1940.     bmi    .lbLEA    ; If real addr not available, we'll LEA
  1941.     get.l    dp,d0
  1942.     bsr    getbase
  1943.     cmp.b    virtBase-hbase(a4),d1
  1944.     bne    .lbLEA    ; If addr and here are in different dic
  1945.             ;  segments, we'll LEA
  1946. .lbfPC    move.l    opAddr,d0
  1947.     get.l    dp,d1
  1948.     sub.l    d1,d0    ; Get PC offset
  1949.     move.l    d0,d1    ; Save in D1
  1950.     bmi.s    .lbf1
  1951.     addq.l    #8,d0    ; Safety margin since dp won't be exactly
  1952.     bra.s    .lbf2    ;  right - so we err on the safe side.
  1953. .lbf1    subq.l    #4,d0
  1954. .lbf2    bsr    WdChk
  1955.     bne.s    .PCtoofar    ; If we're out of 16-bit range
  1956.     cmp.b    #mdX,opMode
  1957.     bne.s    .lbf3
  1958.     bsr    ByteChk    ; Or if mode is index, it's 8-bit range
  1959.     beq.s    .lbfOK
  1960.  
  1961. .PCtoofar            ; Too far for straight PC-rel instruction.
  1962.     cmp.b    #noReg,opBreg    ; If no base reg available, must use PC-rel 
  1963.             ;  anyway
  1964.     bne.s    .lbLEA    ; Otherwise we'll LEA.
  1965.     push.l    d1
  1966.     move.w    #$203C,d0    ; Compile    MOVE.L    #<displ>,D0
  1967.     push.l    d0
  1968.     jsr    wcomma
  1969.     jsr    comma
  1970.     clr.l    opDispl    ; Displ is now zero, and index reg is D0.
  1971.     clr.b    opXreg
  1972.     get.l    dp,d0
  1973.     subq    #6,d0
  1974.     move.l    d0,opAddr
  1975.         ; Reset opAddr so CompExt will compile the
  1976.         ;  right displacement. We have already factored in the
  1977.         ;  distance between the desired addr and DP, so
  1978.         ;  now we just have to allow for the 6 bytes we
  1979.         ;  just compiled.
  1980.  
  1981. .lbfOK    move.b    #mdPCX,opMode    ; OK, we're in range.  Set PC with index mode
  1982.     bra.s    .lbf4
  1983. .lbf3    move.b    #mdPC,opMode    ; Set PC plus displ mode
  1984.  
  1985. .lbf4    get.B    fmkCnt,D2    ; For both PC modes, we set CallOut if reqd
  1986.     put.B    D2,callOut    ;  so this code won't be moved (which would
  1987.             ;  invalidate the PC offset!)
  1988.     tst.b    StoreFlg-hbase(a4)
  1989.     beq    .lb1    ; If not storing, addr is OK now.
  1990.     bsr    .LEAfirst    ; Storing: compile LEA of addr
  1991.     move.b    #mdBD,opMode    ; Mode now becomes BD
  1992.     bset    #6,d0
  1993.     move.b    d0,opBreg
  1994.     clr.l    opDispl    ; With zero displ
  1995.     bra.s    .lb1
  1996.  
  1997. .lbLEA            ; We need to generate an LEA for the addr.
  1998.     move.l    opDispl,d0
  1999.     bsr    WdChk    ; In 16-bit range from base reg?
  2000.     bne.s    .lblAdd    ; No
  2001.     move.b    opMode,d0    ; Yes.  Save mode
  2002.     push.l    d0
  2003.     move.b    #mdBD,opMode    ; Set BD mode
  2004.     bsr    .LEAfirst    ; Compile LEA
  2005.     bset    #6,d0
  2006.     move.b    d0,opBreg    ; Put new base reg in descriptor
  2007.     pop.l    d0    ; Restore mode
  2008.     move.b    d0,opMode
  2009.     clr.l    opDispl    ; Displ now is zero
  2010.     bra.s    .lb1
  2011.  
  2012. .lblAdd    moveq    #0,d0    ; Out of 16-bit range.
  2013.     move.b    WhichA,d0
  2014.     and.b    #7,d0
  2015.     ror.w    #7,d0
  2016.     push.l    d0
  2017.     or.b    opBreg,d0    ; (Note: doesn't matter that AnReg bit is 
  2018.             ;  set)
  2019.     or.w    #$2048,d0    ; Compile  MOVEA.L  A<base>,An
  2020.     push.l    d0
  2021.     jsr    wcomma
  2022.     pop.l    d0
  2023.     or.w    #$D1FC,d0
  2024.     push.l    d0
  2025.     jsr    wcomma    ;    ADDA.L    #displ,An
  2026.     push.l    opDispl
  2027.     jsr    comma
  2028.     move.b    WhichA,opBreg    ; Reset base reg to An in descriptor
  2029.     clr.l    opDispl    ; Displ now is zero
  2030.  
  2031.  
  2032. .lb1    cmp.b    #1,opind
  2033.     ble.s    .lbRtn
  2034.  
  2035.     cmp.b    #mdAn,opMode    ; Indirect count is more than 1
  2036.     bne.s    .nOD    ; Is mode An direct?
  2037.     move.b    #mdBD,opMode    ; Yes - change to base-displ (zero displ),
  2038.     subq.b    #1,opInd    ;  reduce indirect cnt by 1
  2039.     bra.s    .lb1    ;  and try again.
  2040.  
  2041. .nOD    bsr    newOD    ; No - first we compile a load of the source
  2042.     move.b    #Lcode,opSize    ;  to an A reg.
  2043.     move.b    WhichA,opToFrom
  2044.     bsr    CompFetch1
  2045.     clr.l    opDispl
  2046.     move.b    #mdBD,opMode    ; Mode must now be BD with zero displ
  2047.     move.b    WhichA,opBreg    ;  (which eventually compiles as An indirect)
  2048.     moveq    #0,d0
  2049.     move.b    opInd,D0
  2050.     subq    #3,D0
  2051.     bmi.s    .lbRel
  2052.  
  2053. .lbLoop    push.l    d0
  2054.     bsr.s    CompFetch1
  2055.     pop.l    d0
  2056.     dbra    d0,.lbLoop
  2057.  
  2058. .lbRel    bsr    ReleaseOD    ; Now update passed-in desc
  2059.     clr.l    opDispl
  2060.     move.b    #mdBD,opMode    ; May have been index mode
  2061.     move.b    WhichA,opBreg
  2062.     move.b    #1,opInd
  2063. .lbRtn    pop.l    A1    ; Restore A1
  2064.     btst    #flFP,LBsavFlgs    ; And FP bit in flags
  2065.     beq.s    .lbOut
  2066.     bset    #flFP,opFlags
  2067. .lbOut    rts
  2068.  
  2069. ;        =======================
  2070.  
  2071. ;        COMPFETCH and COMPSTORE
  2072.  
  2073. ;        =======================
  2074.  
  2075. ; CompFetch and CompStore and are higher-level than compMOVE, and are
  2076. ; called when we need to compile instructions to move data between memory
  2077. ; and the stack or a D register.  We allow a few abstractions such the stack
  2078. ; being an index register, lobase always addressing the main dic and
  2079. ; 4-byte displacements.
  2080.  
  2081. ; Here we only need the A0 descriptor, since the "other" location (reg or stack)
  2082. ; participating in the operation is marked in the opToFrom field.
  2083. ; A0 and A1 are preserved.
  2084.  
  2085. ; Both CompFetch and CompStore allocate a temporary descriptor, then call
  2086. ; LoadBase to handle the above abstractions.  LoadBase generates any
  2087. ; necessary extra instructions, and modifies the temp descriptor
  2088. ; appropriately.  LoadBase gets called from a lot of other places as well
  2089. ; - note it modifies whatever descriptor is passed to it, so a temp copy
  2090. ; should be used if the original is still needed.
  2091.  
  2092.  
  2093. CompFetch1
  2094.     MOVE.B    FetchSize,D2    ; Pick up requested fetch size
  2095.     MOVE.B    #Lcode,FetchSize-hbase(A4)
  2096.             ; and immediately reset default for safety
  2097.     LEA    ODdst,A1    ; Set up dest desc in ODdst
  2098.     BSR.S    setupOD    ;  with A1 pointing there
  2099.     BMI    CompMove    ; If dest is stack, compile MOVE
  2100.     MOVE.B    D2,opSize(A1)    ; It isn't.  Set required size.
  2101.     MOVE.B    opMode,D0
  2102.     CMP.B    opMode(A1),D0    ; Are src and dst both Dn or An?
  2103.     BNE    CompMove    ; No - compile MOVE
  2104.     CMP.B    #mdDn,D0
  2105.     BEQ.S    .RtoR
  2106.     CMP.B    #mdAn,D0
  2107.     BNE    CompMove
  2108.  
  2109. .RtoR    MOVE.B    opReg,D0
  2110.     CMP.B    opReg(A1),D0    ; Yes.  Same register?
  2111.     BEQ.S    .RtoR1    ;  Yes - don't compl anything, no matter 
  2112.             ;   what.
  2113.     TST.B    svForceToR-hbase(A4)
  2114.             ;  No.  Are we forcing a reg to reg move?
  2115.     BNE    CompMOVE    ;   Yes - compile MOVE
  2116.  
  2117. .RtoR1    MOVE.B    opReg,D3    ;   No - don't compile anything - and set up
  2118.     BSR    ReleaseOD    ;   to return from CompFetch, not CompFetch1.
  2119.             ; Careful - this is a bit sneaky.
  2120.             ;  Release temp OD,
  2121.     MOVEM.L    (A6)+,A0/A1    ;  restore A0, A1
  2122.     MOVE.B    D3,opToFrom    ; Set opToFrom to the reg actually used
  2123.     ADDQ    #4,A7    ; Pop rtn addr from CompFetch
  2124.     RTS        ; Return to original caller
  2125.  
  2126.  
  2127. CompFetch
  2128.     movem.l    a0/a1,-(a6)    ; Save regs
  2129.     move.b    ForceToR,svForceToR-hbase(a4)
  2130.     sf    ForceToR-hbase(a4)
  2131.     move.b    InhibitClr,svInhibitClr-hbase(a4)
  2132.     sf    InhibitClr-hbase(a4)
  2133.     BSR    NewOD    ; A0 -> temp OD
  2134.  
  2135. ; Now we check for the case where the source is FP and the dest is the stack.
  2136. ; In this case a floating heap location will be allocated for the dest by
  2137. ; FPmove, using A0, so we'll need to use A1 for the LoadBase.  In all other cases
  2138. ; we use A0 for the LoadBase.
  2139.  
  2140.     btst    #flFP,opFlags
  2141.     beq.s    .cf1
  2142.     tst.b    opToFrom
  2143.     bpl.s    .cf1
  2144.     moveq    #1,d0
  2145.     bra.s    .cf2
  2146. .cf1    moveq    #0,D0
  2147. .cf2    bsr    LoadBase
  2148.     bsr.s    CompFetch1
  2149.     bsr    ReleaseOD    ; Finished: release temp OD,
  2150.     movem.l    (A6)+,A0/A1    ;  restore regs then return.
  2151.     rts
  2152.  
  2153. destFP    byte
  2154.     align
  2155. CompStore
  2156.     MOVEM.L    A0/A1,-(A6)    ; Save A0, A1
  2157.     st    StoreFlg-hbase(a4)
  2158. ;    move.b    opFlags,destFP-hbase(a4)    ; Remember if dest is floating
  2159.     BSR    NewOD    ; A0 -> temp OD
  2160.     MOVEQ    #1,D0
  2161.     BSR    LoadBase
  2162.     cmp.b    #otFPmon,(a0)
  2163.     blt.s    .cs1
  2164.     cmp.b    #otFPend,(a0)
  2165.     blt.s    .csFPmon
  2166.  
  2167. .cs1    lea    ODsrc,A1    ; Set up source desc in ODsrc
  2168.     bsr.s    setupOD    ;  with A1 pointing there
  2169.     exg    A0,A1    ; Exg A0 and A1 so src and dest are right
  2170. ;    btst    #flFP,destFP-hbase(a4)
  2171. ;    beq.s    .cs2
  2172. ;    bset    #flFP,opFlags(a1)    ; Set dest floating flag if nec
  2173.     bra.s    .cs2
  2174.  
  2175. .csFPmon            ; "Store" is an FP monadic op on dest 
  2176.             ;  location
  2177.     move.l    a0,a1    ; src and dst descriptors are the same
  2178.     bra.s    .cs2
  2179.  
  2180. CompStore1        ; Enter here if the two descriptors are set up already
  2181.     movem.l    a0/a1,-(a6)    ; Save A0, A1
  2182.     bsr    NewOD    ; A0 -> temp OD
  2183. .cs2    move.b    (a1),operation-hbase(a4)
  2184.     move.b    opShiftCnt,shiftCnt-hbase(a4)
  2185.     clr.b    FPA-hbase(a4)    ; In case it's an FP op
  2186.     bsr    OP2
  2187.     bsr    ReleaseOD
  2188.     sf    StoreFlg-hbase(a4)    ; Restore default to StoreFlg (false)
  2189.     movem.l    (a6)+,a0/a1    ;  restore A0, A1 then return.
  2190.     rts
  2191.  
  2192.  
  2193. ; CompAnyNew is higher-level than CompFetch and CompStore.  It compiles an
  2194. ; arbitrary descriptor, which must be in ODnew.  We assume saveOD has
  2195. ; previously been called, we optimize if possible, and in the case
  2196. ; of a fetch, push the descriptor at the end.
  2197.  
  2198. CompAnyNew
  2199.     LEA    ODnew,A0
  2200.     CMP.B    #otJSR,(A0)
  2201.     BEQ.S    .doJSR
  2202.     CMP.B    #otFetch,(A0)
  2203.     BLT.S    .doStore
  2204.     MOVE.B    #stkPush,opToFrom
  2205.     BSR    CompFetch
  2206.     BRA    pushOD
  2207.  
  2208. .doStore
  2209.     MOVE.B    #stkPop,opToFrom
  2210.     CMP.B    #otStore,(A0)
  2211.     BEQ    stchk    ; Maybe optimize if this is a straight store
  2212.     BRA    CompStore
  2213.  
  2214. .doJSR    MOVEM.L    A0/A1,-(A6)    ; Save A0, A1
  2215.     BSR    NewOD    ; A0 -> temp OD
  2216.     MOVEQ    #0,D0
  2217.     BSR    LoadBase
  2218.     MOVE.W    #$4E80,D0    ; JSR opcode
  2219.     BSR    CompMop2
  2220.     BSR    ReleaseOD    ; Finished: release temp OD,
  2221.     MOVEM.L    (A6)+,A0/A1    ;  restore A0, A1 then return.
  2222.     RTS
  2223.  
  2224.  
  2225. ;    =================================
  2226.  
  2227. ; FetchToA and FetchToD compile the A0 descriptor (which we assume is a fetch
  2228. ; descriptor) so that its destination is an A or D register respectively.
  2229. ; This will be the reg whose number is in D0, unless we are doing FetchToD
  2230. ; and the fetch's source was already a D register.  In that case
  2231. ; nothing is compiled, but the descriptor's ToFrom field is set to 
  2232. ; that register, so we know that that is where the data is.
  2233. ; The A/D reg number actually used is left in D0.  It may not be the same
  2234. ; as that requested.
  2235.  
  2236. FetchToA
  2237.     OR.B    #AnReg,D0
  2238. FetchToD
  2239. FetchToReg
  2240.     MOVE.B    D0,opToFrom    ; Set dest to Dn/An
  2241.     BSR    CompFetch    ; Recompile - dest reg may change
  2242.     MOVEQ    #0,D0
  2243.     MOVE.B    opToFrom,D0    ; Leave reg no in D0
  2244.     AND.B    #7,D0
  2245.     RTS
  2246.  
  2247.  
  2248. ; GetToReg is a bit higher-level than FetchToD etc.  It gets the top operand
  2249. ; to the requested register.
  2250. ; It will work in any situation, and checks the preceding descriptors to see
  2251. ; if they can be recompiled to get the operand to the requested register.
  2252. ; D0 on entry is as for FetchToReg.
  2253. ; D0 on exit is left indicating the actual reg used.
  2254. ; We do guarantee that if a D reg is requested, a D reg will be used, and
  2255. ; likewise for an A reg.  In actual fact, if A0 is requested it will always
  2256. ; be used (since any arithmetic on an A reg will always be on A0)
  2257. ; - hStkObj assumes this!!!
  2258.  
  2259. GetToReg
  2260.     movem.l    a0/a1,-(a6)
  2261.     bsr    ChkOpt
  2262.     beq.s    .gdNo
  2263.     cmp.b    #otFetch,D1
  2264.     beq.s    .gdF
  2265.     cmp.b    #otPMend,d1
  2266.     bge.s    .gdNo
  2267.  
  2268. ; Preceding op is integer arith/logical.
  2269.  
  2270.     move.b    d0,d2
  2271.     and.b    #AnReg,d2
  2272.     beq.s    .g2rOP    ; If we're requesting An
  2273.     cmp.b    #otADD,D1    ; we can't optimize unless the
  2274.     blt.s    .gdNo    ; op is ADD or SUB, since we can
  2275.     cmp.b    #otSUB,D1    ; use An as a work reg.
  2276.     bgt.s    .gdNo
  2277.  
  2278. .g2rOP    PUSH.L    D0
  2279.     LEA    ODsav,A0
  2280.     BSR    op2Reg
  2281.     MarkDP
  2282.     MOVE.L    (A6),D1
  2283.     MOVE.B    D1,D2
  2284.     EOR.B    D0,D2
  2285.     AND.B    #AnReg,D2
  2286.     BEQ.S    .gdOut    ; Out if we wanted a D (A) and got a D (A)
  2287.     MOVE.W    D1,D3
  2288.     AND.W    #AnReg,D3    ; AnReg bit is set in D3 if dest to be An
  2289.     SEQ    D2
  2290.     AND.W    #8,D2    ; $8 bit is set in D2 if src to be An
  2291.     AND.W    #7,D0
  2292.     AND.W    #7,D1
  2293.     ROR.W    #7,D1
  2294.     OR.W    D1,D0
  2295.     OR.W    D2,D0
  2296.     OR.W    D3,D0
  2297.     OR.W    #$2000,D0    ; MOVE.L  srcReg,dstReg
  2298.     PUSH.L    D0
  2299.     JSR    wcomma
  2300.     POP.L    D0
  2301.     bra.s    .gdRtn
  2302.  
  2303. .gdOut    ADDQ    #4,A6
  2304.  
  2305. .gdRtn    movem.l    (a6)+,a0/a1
  2306.     rts
  2307.  
  2308. .gdF    LEA    ODsav,A0    ; Fetch preceded.
  2309.     backDP
  2310.     BSR.S    FetchToReg
  2311.     bra.s    .gdRtn
  2312.  
  2313. .gdNo    MOVE.W    D0,D1    ; No optimization possible.
  2314.     AND.W    #AnReg,D1
  2315.     AND.W    #7,D0
  2316.     PUSH.L    D0
  2317.     ROR    #7,D0
  2318.     OR.W    xPopD0,D0
  2319.     OR.W    D1,D0
  2320.     PUSH.L    D0
  2321.     JSR    wcomma    ; Compile  POP.L  <reg>
  2322.     POP.L    D0
  2323.     bra.s    .gdRtn
  2324.  
  2325.  
  2326. ;        ===================
  2327.  
  2328. ;                OP2
  2329.  
  2330. ;        ===================
  2331.  
  2332. ; OP2 compiles all dyadic operations that can be optimized.
  2333. ; The kind of operation is indicated in Operation (byte) on entry.
  2334. ;
  2335. ; A0 -> source descriptor
  2336. ; A1 -> destination descriptor
  2337. ;
  2338. ; Note that any necessary calls to LoadBase must have been done already, since
  2339. ; here we don't always know which A regs are available.
  2340. ; So here we DON'T check the opind field, except to check if it's zero.
  2341. ;
  2342. ; For monadic operations, A0 is ignored.
  2343.  
  2344.     loc
  2345.  
  2346. Operation    byte        ; Saves operation code
  2347. ShiftCnt    byte        ; Shift count for shifts
  2348.     align
  2349. RevOpnds    dc.w    0
  2350. LitVal    long        ; Saves any literal value
  2351.  
  2352. OP2    moveq    #0,d2
  2353.     move.b    Operation,d2    ; Operation code to D2
  2354.     cmp.b    #otStore,d2
  2355.     beq    compMOVE    ; If MOVE
  2356.     cmp.b    #otMon,d2
  2357.     blt.s    .opSR
  2358.     cmp.b    #otSHIFT,d2
  2359.     ble    .opMon    ; If monadic (NEG, NOT or const shift)
  2360.  
  2361. .opSR    MOVEM.L    A0-A2,-(A6)    ; Save regs
  2362.     cmp.b    #otFPops-1,d2
  2363.     bge    .opFP    ; If floating-point (including FCMP)
  2364.     CMP.B    #mdLit,opMode(A1)
  2365.     BEQ    .opLitC    ; If 2nd operand is literal, must be CMP
  2366.     CMP.B    #mdAn,opMode(A1)
  2367.     BEQ.S    .opDstAn    ; If dest An, some things are different
  2368.     CMP.B    #mdLit,opMode
  2369.     BEQ    .opLit    ; If 1st opnd is literal
  2370.  
  2371. ; Now we've got rid of the special cases, either the source or destination
  2372. ; (or both) must be Dn.  If EOR, the source must be Dn.
  2373.  
  2374. .opToD
  2375.     cmp.b    #mdDn,opMode(A1)    ; If dest isn't Dn, force source to Dn
  2376.     bne    .srcToD
  2377.     cmp.b    #otEOR,D2    ; .. ditto if operation is EOR
  2378.     beq    .srcToD
  2379.     tst.b    opind    ; Dest is Dn
  2380.     beq.s    .opSrcAd    ; Source is an addr. Get it to A0
  2381.     cmp.b    #Lcode,opSize(a0)    ; Otherwise if it's a long op, we can
  2382.     beq.s    .opComp    ;  compile it straight away
  2383.     cmp.b    #Wcode,opSize(a0)
  2384.     bne    .srcToD    ; If byte op, force source to Dn
  2385.     btst    #flExt,opFlags(a0)
  2386.     beq    .srcToD    ; Likewise if word but no extension
  2387. .opSrcAd    moveq    #0,d0    ; Word with extension.  Get source
  2388.     bsr    FetchToA    ;  to A0 to extend it
  2389.     UseODsrc
  2390.     move.b    #mdAn,opMode
  2391.     move.b    d0,opReg
  2392.     moveq    #0,d2
  2393.     move.b    operation,d2
  2394.     cmp.b    #otSUB,d2    ; Is op add or subtract?
  2395.     bgt    .srcToD    ; No - can't use A0 as source, so
  2396.             ;  move it to Dn
  2397.     
  2398. .opComp    move.b    opReg(A1),opToFrom(A0)    ; If we got here, we can compile the
  2399.     lsl.w    #1,d2    ;    operation  straight away.
  2400.     lea    xadds-(otADD*2),a2
  2401.     move.w    0(a2,d2.w),d0
  2402. .op3    bsr    CompMOp
  2403.     bra    .opRtn    ; Finished.
  2404.  
  2405. .opDstAn            ; Destination is An.
  2406.     cmp.b    #otSUB,d2
  2407.     bgt    .srcToD    ; If not ADD or SUB, we'll make the
  2408.             ; src Dn and deal with it a bit later
  2409.     cmp.b    #mdLit,opMode    ; Check for a literal source
  2410.     bne.s    .opa1    ; It isn't
  2411.     move.l    opLit,d0    ; It is.  We can't use ADDI/SUBI here,
  2412.     moveq    #-8,d1    ;  only ADDA/SUBA or ADDQ/SUBQ.
  2413.     cmp.l    d1,d0
  2414.     blt.s    .opa1    ; Can we use ADDQ/SUBQ?
  2415.     moveq    #8,d1
  2416.     cmp.l    d1,d0
  2417.     ble    .opQ    ; Yes: do it
  2418.     
  2419. .opa1    MOVE.B    opReg(A1),opToFrom(A0)    ; In all other cases we must use
  2420.     lsl.w    #1,d2    ;    ADDA/SUBA.
  2421.     lea    xadds-(otADD*2),a2
  2422.     move.w    0(a2,d2.w),d0
  2423.     OR.W    #$1C0,D0    ; Make the op ADDA.L or SUBA.L
  2424.     BRA.S    .op3
  2425.  
  2426. ; Monadic operation.  A1 desc is the only operand.
  2427.  
  2428. .opMon    move.l    a1,a0
  2429.     cmp.b    #otSHIFT,d2
  2430.     beq.s    .opShift
  2431.     lsl.w    #1,d2
  2432.     lea    xadds-(otADD*2),a2
  2433.     move.w    0(a2,d2.w),d0
  2434.     bra    CompMOp1
  2435.  
  2436. ; Immediate shifts.  These are like monadic ops, except that the operand being
  2437. ; shifted must be in Dn, unless it's a shift of one.  So if it isn't, we have
  2438. ; to move it to Dn then move it back.  We assume the caller has ensured the
  2439. ; shift count is 8 or less, since that's all we can do in an immediate shift.
  2440.  
  2441. .opShift    cmp.b    #mdDn,opMode
  2442.     bne.s    .opshMem
  2443.  
  2444. .opsh1    move.w    #$E180,d0    ; LSL/R opcode
  2445.     or.b    opReg,d0
  2446.     move.b    shiftCnt,d1
  2447.     beq.s    .opshOut    ; Shift of zero compiles nothing
  2448.     move.b    d1,d2
  2449.     subq.b    #1,d2
  2450.     beq.s    .opshOneL    ; If left shift of one (see below)
  2451.     bpl.s    .opsh2
  2452.     neg.b    d1    ; If shifting right, make cnt positive
  2453.     eor.w    #$100,d0    ;  and adjust opcode
  2454. .opsh2    and.w    #7,d1
  2455. .opsh3    ror.w    #7,d1
  2456.     or.w    d1,d0
  2457. .opsh4    push.l    d0
  2458.     jmp    wcomma
  2459.  
  2460. .opshOneL    move.w    #$D080,d0    ; Left shift of one:
  2461.     moveq    #0,d1    ; We compile  ADD.L  Dn,Dn
  2462.     move.b    opReg,d1    ; since this is faster on some CPUs
  2463.     or.b    d1,d0
  2464.     bra.s    .opsh3
  2465.  
  2466. .opshMem    tst.b    opMode    ; If not already Dn, should be stack
  2467.     bpl.s    .opshErr    ; Deliberate crash if not!
  2468.     compop    xpopD0
  2469.     clr.b    opReg
  2470.     bsr.s    .opsh1
  2471.     compop    xpushD0
  2472. .opshOut    rts
  2473.  
  2474. .opshErr    dc.w    $FFE8
  2475.  
  2476. ; Dest wasn't Dn.  We must ensure source is.
  2477.  
  2478. .srcToD    moveq    #0,d0
  2479.     cmp.b    #mdDn,opMode
  2480.     bne.s    .opF2D    ; Skip FetchToD call if already in Dn
  2481.     move.b    opReg,d0    ;  - FetchToD would have recognized this
  2482.     bra.s    .opinD    ;  and done nothing, but skipping the call
  2483.             ;  saves some time.
  2484.  
  2485. .opF2D    move.b    opSize(A1),fetchSize-hbase(A4)
  2486.     bsr    FetchToD    ; Forces src to Dn
  2487. .opinD    MOVE.B    #Lcode,fetchSize-hbase(A4)
  2488.             ; Reset default size - shouldn't be necessary
  2489.             ;  here, but I'm a suspicious character.
  2490.     EXG    A0,A1    ; Now we look at the dest mode:
  2491.     MOVE.B    D0,opToFrom
  2492.  
  2493. .op0    moveq    #0,d2
  2494.     move.b    operation,d2
  2495.     lsl.w    #1,d2
  2496.     lea    xadds-(otADD*2),a2
  2497.     move.w    0(a2,d2.w),d0
  2498.     cmp.w    #otCMP*2,d2
  2499.     bne.s    .opDDchk
  2500.  
  2501. ; CMP with source Dn.  CMP is implicitly "dst Dn" mode, but without the $100 bit set.
  2502. ; Thus the operands are the "wrong" way around, and we need to call RevCond.
  2503.  
  2504.     bsr    RevCond
  2505.     bra.s    .op2
  2506.  
  2507. .opDDchk    cmp.b    #mdDn,opMode
  2508.     beq.s    .opDD    ; If src and dest are both Dn
  2509.     cmp.b    #mdAn,opMode
  2510.     beq.s    .opDA    ; If dest is An, something's wrong!
  2511.     or.w    #$100,D0
  2512. .op1    move.w    RevOpnds,D1
  2513.     eor.w    D1,D0
  2514. .op2    bsr    CompMOp
  2515.  
  2516. .opRtn
  2517.     CLR.W    RevOpnds-hbase(a4)
  2518. .opRtn1    MOVEM.L    (A6)+,A0-A2
  2519.     RTS
  2520.  
  2521. .opDD            ; Src and dst are both Dn.  If the op isn't
  2522.             ; EOR, we must use "dst Dn" mode.
  2523.     CMP.B    #otEOR,operation-hbase(a4)
  2524.     BEQ.S    .op1    ; If EOR, go ahead and compile the op
  2525.     MOVE.B    opToFrom,D0    ; Otherwise we have to swap the reg numbers
  2526.     MOVE.B    opReg,opToFrom    ; and not set the $100 op-mode bit.
  2527.     MOVE.B    D0,opReg
  2528.     BRA.S    .op1
  2529.  
  2530. .opDA    dc.w    $FFE1    ; We won't ever get here.  Never ever.
  2531.  
  2532.  
  2533. .opLit    TST.W    RevOpnds-hbase(A4)
  2534.     BEQ.S    .opL0
  2535.     MOVEQ    #0,D0
  2536.     BSR    FetchToD
  2537.     BRA.S    .opinD
  2538.  
  2539. .opL0    move.l    opLit,d0
  2540.     move.l    d0,LitVal-hbase(A4)
  2541.     cmp.b    #otSUB,D2
  2542.     BGT.S    .opL1    ; If not plus or minus, we don't
  2543.     MOVEQ    #-8,D1    ; have a "quick" instruction
  2544.     CMP.L    D1,D0
  2545.     BLT.S    .opL1
  2546.     MOVEQ    #8,D1
  2547.     CMP.L    D1,D0
  2548.     BGT.S    .opL1
  2549.  
  2550. .opQ    TST.L    D0    ; We come here to compile a "quick" instrn
  2551.     BEQ.S    .opRtn    ; Add or subtract literal zero means do 
  2552.             ;  nothing
  2553.     BPL.S    .opQ1    ; Compile the "quick" instruction:
  2554.     NEG.W    D0    ; If negative, make positive and change the
  2555.     EOR.W    #3,D2    ;  operation (+ or -) appropriately
  2556. .opQ1    ROR.W    #7,D0
  2557.     lsl.w    #1,d2
  2558.     lea    xaddq-(otADD*2),a2
  2559.     or.w    0(a2,d2.w),d0
  2560.     move.l    a1,a0
  2561.     bsr    CompMOp1
  2562.     bra    .opRtn
  2563.  
  2564. .opL1    bsr    ByteChk    ; Literal, not quick.  Value in D0.  Short?
  2565.     beq.s    .srcToD    ; Yes - use MOVEQ to Dn.  It's shorter and
  2566.         ; faster than immediate mode.
  2567.     bra.s    .opL3
  2568.  
  2569. .opLitC    bsr    RevCond    ; We come here for 2nd operand literal
  2570.             ;  (must be CMP)
  2571.     cmp.b    #mdLit,opMode
  2572.     bne.s    .opL2
  2573.  
  2574.     bsr.s    CCmp    ; If both operands are literal, we have
  2575.     bra.s    .opRtn    ; conditional compilation
  2576.  
  2577. .opL2    EXG    A0,A1
  2578.     move.l    opLit,d0
  2579.     move.l    d0,LitVal-hbase(A4)
  2580.     bsr    ByteChk
  2581.     beq    .srcToD
  2582.  
  2583. .opL3    lsl.w    #1,d2
  2584.     lea    xaddi-(otADD*2),a2
  2585.     move.w    0(a2,d2.w),d0
  2586.     exg    a0,a1
  2587.     bsr    GetSize
  2588.     bsr    EAbits
  2589.     push.l    d0
  2590.     jsr    wcomma
  2591.     move.l    LitVal,D0
  2592.     bsr    CompLit
  2593.     bsr    CompExt
  2594.     bra.s    .opRtn
  2595.  
  2596. ; Compare with both operands literal.  We take this as conditional
  2597. ; compilation.
  2598.  
  2599. CCmp    PUSH.L    A2    ; Save A2
  2600.     PUSH.L    D0    ; Save D0
  2601.     MOVE.B    condition,D2    ; Get condition
  2602.     MOVE.B    Rcond,D1    ; And reversed condition flag
  2603.     OR.B    #$50,D2    ; Form Scc opcode byte
  2604.     EOR.B    D1,D2
  2605.     CLR.B    Rcond-hbase(A4)
  2606.     MOVE.B    D2,.doit-hbase(A4) ; Store Scc for execution
  2607.     BSR    FlushCache
  2608.     POP.L    D0    ; Is this a test or compare?
  2609.     BEQ.S    .cc1
  2610.     MOVE.L    opLit,D0
  2611.     CMP.L    opLit(A1),D0    ; Compare
  2612.     BRA.S    .doit
  2613. .cc1    TST.L    opLit    ; Test
  2614. .doit    SEQ    D0    ; Scc patched here!
  2615.  
  2616.     TST.B    ifFlg-hbase(A4)
  2617.     bne.s    .setCCmpFlg
  2618.     MOVE.B    D0,D1
  2619.     MOVEQ    #0,D0
  2620.     BSR    CompMOVEQ
  2621.     MOVE.B    #6,condition-hbase(A4)
  2622.     BRA.S    .ccOut
  2623.  
  2624. .setCCmpFlg
  2625.     ADDQ.B    #2,D0
  2626.     PUSH.L    A1
  2627.     put.b    D0,CCmpFlg
  2628.     POP.L    A1
  2629. .ccOut    POP.L    A2    ; Restore A1 and A2
  2630.     RTS
  2631.  
  2632. ; Floating point operations.
  2633.  
  2634. FPDP    long    ; Saves DP value for just after FP op is compiled.
  2635.         ; This will be before the code is compiled to move
  2636.         ; the result from the FPU back to the stack or
  2637.         ; wherever.  We will save FPDP in the descriptor
  2638.         ; and use it if we optimize.
  2639.  
  2640. FHeapChk
  2641.     btst    #flFP,opFlags    ; Is operand on the floating heap?
  2642.     bne.s    .fhOut    ; No
  2643.     move.b    FPA,d0    ; Yes. Get which A reg to use for dereference
  2644.     bne.s    .fh1
  2645.     tst.w    RevOpnds-hbase(a4)
  2646.     bne.s    .fh1
  2647.     or.b    #1,FPdispFlg-hbase(a4)    ; If source, remember to dispose it
  2648. .fh1    bsr    FetchToA
  2649.     move.b    #mdBD,opMode    ; Change source descriptor to (An)
  2650.     move.b    FPA,opBreg
  2651.     move.b    #1,opind
  2652.     clr.l    opDispl
  2653.     move.b    #fbFP,opFlags
  2654.     or.b    #1,FPA-hbase(a4)
  2655. .fhOut    rts
  2656.  
  2657. .opFP
  2658. ;    clr.b    FPA-hbase(a4)
  2659. ;    tst.w    RevOpnds-hbase(a4)
  2660. ;    beq.s    .fp1
  2661. ;    exg    a0,a1    ; Swap operands if necessary - for FP ops we
  2662.             ;  can't incorporate this in the op itself
  2663.             ; NO - not doing this yet (or ever?)
  2664.     
  2665. ;    cmp.b    #otFMOVE,Operation-hbase(a4)
  2666. ;    beq    .opFPmove    ; NOTE - in this case, CompMove should have
  2667.             ; been called, so we shouldn't need this.
  2668.  
  2669. ; Now here's the real code!!!
  2670.  
  2671. .fp1    bsr.s    FHeapChk    ; Check source operand for FP heap. We
  2672.             ;  have to do this first so that stack
  2673.             ;  operands come out the right way around.
  2674.     bsr    FspecChk    ; Check source for special
  2675.     cmp.b    #mdFPn,opMode(a1)    ; Is dest FPn?
  2676.     sne    d7
  2677.     beq.s    .fp2    ; Yes (and leave D7 clear)
  2678.     cmp.b    #mdFPn,opMode    ; No  (and leave D7 set)
  2679.     bne.s    .fpTempR    ; Is source FP0 or FP1?
  2680.     cmp.b    #1,opReg
  2681.     bgt.s    .fpTempR    ; No - we have to use a temp FP reg.
  2682.             ; Yes- is op commutative?
  2683.     cmp.b    #otFPnoncom,operation-hbase(a4)
  2684.     bge.s    .fpTempR    ; No - we'll use a temp anyway
  2685.     exg    a0,a1    ; Yes - swap operands
  2686.     neg.b    d7    ; Set d7 to 1 to show what we did
  2687.     move.b    #1,FPA-hbase(a4)    ; The mem operand is really a destination
  2688.     bra.s    .fp2
  2689.  
  2690. .fpTempR    push.l    a0    ; We need to use a temp FP reg.
  2691.             ; Save src desc ptr
  2692.     bsr    newClrOD    ; Get a new OD for FP0 descriptor
  2693.     move.b    #mdFPn,opMode
  2694.     move.b    #fbFP,opFlags
  2695.     clr.b    opReg
  2696.     exg    a0,a1
  2697.     cmp.b    #otFPmon,operation-hbase(a4)
  2698.     bge.s    .fpPop
  2699.     move.b    FPA,d6    ; Compile a move of the dest operand to FP0
  2700.     bsr    FPmove    ;  Save FPA no. used for any FP heap 
  2701.             ;  dereferencing in D6.
  2702. ;    clr.b    FPA-hbase(a4)    ; Ignore returned D0 flag as this operand 
  2703.             ;  mustn't be disposed from the FP heap
  2704. .fpPop    pop.l    a0    ; Restore src desc ptr
  2705.  
  2706. .fp2    bsr.s    FHeapChk    ; Check source operand again (may have 
  2707.             ;  changed)
  2708.     moveq    #0,d0
  2709.     move.b    Operation,d0
  2710.     lsl.w    #2,d0
  2711.     lea    xFPops-((otFPops)*4),a2
  2712.     move.l    0(a2,d0.w),d0
  2713.     cmp.b    #mdFPn,opMode
  2714.     bne.s    .fpMem2reg
  2715.  
  2716.     move.b    opReg,d1
  2717.     lsl.w    #3,d1
  2718.     bra.s    .fpDstReg
  2719.  
  2720. .fpMem2reg
  2721.     or.w    #$4800,d0
  2722.     swap    d0
  2723.     bsr    EAbits
  2724.     swap    d0
  2725.     moveq    #0,d1
  2726. .fpDstReg
  2727.     or.b    opReg(a1),d1
  2728.     lsl.w    #7,d1
  2729.     or.w    d1,d0
  2730.     push.l    d0
  2731.     jsr    comma
  2732.     bsr    CompExt
  2733.     bsr.s    ChkFPdisp
  2734.  
  2735.     push.l    a1
  2736.     get.l    DP,FPDP-hbase(a4)
  2737.     pop.l    a1
  2738.  
  2739. ; Now we do the final cleaning up.
  2740.  
  2741.     tst.b    d7    ; Is original destination FPn?
  2742.     beq.s    .fpEnd    ; Yes - we're done
  2743.     cmp.b    #otFPcmp,operation-hbase(a4)
  2744.     beq.s    .fpEnd    ; Also if it was a compare
  2745.  
  2746.     move.l    a1,a0    ; Move result to destination:
  2747.     move.l    4(a6),a1    ; Restore original dest desc ptr to a1
  2748.     btst    #flFP,opFlags(a1)    ; Is it on FP heap?
  2749.     bne.s    .fp4    ; No
  2750.             ; Yes - data addr will be in A0 or A1 as
  2751.             ;  indicated by D6, as long as this was
  2752.             ;  a dyadic op.
  2753.     cmp.b    #otFPmon,operation-hbase(a4)
  2754.     bge.s    .fpCUmon    ; It wasn't
  2755.     move.l    a0,a1    ; It was.
  2756.     UseODsrc
  2757.     move.b    #mdBD,opMode    ; We use a desc specifying An
  2758.     move.b    #1,opind
  2759.     exg    a0,a1
  2760.  
  2761. ;     tst.w    RevOpnds-hbase(a4)
  2762. ;    bne.s    .useA0
  2763. ;    move.b    #AnReg+1,opBreg(a1)
  2764. ;    bra.s    .fp3
  2765. ;.useA0    move.b    #AnReg,opBreg(a1)    ; Except if opnds were reversed, it's a0
  2766.  
  2767.     add.b    #AnReg,d6
  2768.     move.b    d6,opBreg(a1)
  2769. .fp3    clr.l    opDispl(a1)
  2770.     move.b    #fbFP,opFlags(a1)
  2771. .fp4    bsr    FPmove
  2772. .fpEnd    tst.b    d7
  2773.     bpl    .opRtn
  2774.     bsr    releaseOD    ; Get rid of temp OD we allocated for FP0
  2775.     bra    .opRtn
  2776.  
  2777. .fpCUmon            ; Clean up a monadic with result to heap
  2778.     bsr    ToNewHeap
  2779.     bra.s    .fpEnd
  2780.  
  2781.  
  2782. ;.opFPmove
  2783. ;    bsr    FPmove
  2784. ;    or.b    d0,FPdispFlg-hbase(a4)
  2785. ;    bsr.s    ChkFPdisp
  2786. ;    bra    .fpEnd
  2787.  
  2788.  
  2789. ChkFPdisp
  2790.     push.l    a1
  2791.     tst.b    FPdispFlg-hbase(a4)
  2792.     beq.s    .cfdOut
  2793.     bmi.s    .cfd2
  2794.     get.l    ptrFPdisp,-(a6)
  2795.     bra.s    .cfdJSR
  2796. .cfd2    get.l    ptrFPdisp2,-(a6)
  2797.  
  2798. .cfdJSR    bsr    CompJSRnoPush
  2799.  
  2800. .cfdOut    pop.l    a1
  2801.     clr.b    FPdispFlg-hbase(a4)
  2802.     rts
  2803.  
  2804. ; CompFPnew compiles a call to the routine to allocate a new FP heap block.
  2805.  
  2806. CompFPnew
  2807.     push.l    a1
  2808.     get.l    ptrFPnew,-(a6)
  2809.     bsr    CompJSRnoPush
  2810.     pop.l    a1
  2811.     rts
  2812.  
  2813.  
  2814. ;        ======================
  2815.  
  2816. ;                OP2REG
  2817.  
  2818. ;        ======================
  2819.  
  2820. ; Op2Reg recompiles the A0 pm-type descriptor to a Dn or An destination.
  2821. ; D0 = n for Dn, AnReg+n for An.  Leaves D0 with the actual D reg used.
  2822. ; In several situations this will be different from the one requested.
  2823. ; The caller will need to check for this, since the appropriate action
  2824. ; varies.  E.g. for IF we don't need to do anything more at all.
  2825.  
  2826. ; Important note: DON'T DO BackDP on the same descriptor before calling Op2Reg!!
  2827. ; We need the unbacked DP here, and will take care of it.
  2828.  
  2829.     loc
  2830.  
  2831. ReqReg    byte
  2832.     align
  2833.  
  2834. Op2Reg
  2835.     movem.l    A0/A1,-(A6)    ; Save
  2836.     move.b    D0,reqReg-hbase(A4)
  2837.     move.b    opShiftCnt,ShiftCnt-hbase(a4)
  2838.             ; We set up Operation below at .o2r2
  2839.     bsr    newClrOD    ; Set up a new OD for the Dn/An dest
  2840.     btst    #6,D0    ; An requested?
  2841.     bne.s    .op2rAn
  2842.     move.b    #mdDn,opMode
  2843.     bra.s    .op2r1
  2844. .op2rAn    move.b    #mdAn,opMode
  2845.     bclr    #6,D0
  2846. .op2r1    move.b    D0,opReg
  2847.     move.b    #1,opind
  2848.     move.b    #Lcode,opSize
  2849.     move.l    A0,A1
  2850.     move.l    (A6),A0    ; Recover A0 but leave on stack as well
  2851.     moveq    #0,D0
  2852.     move.b    (a0),d1    ; Opcode to D1
  2853.     cmp.b    #otCMP,d1
  2854.     beq    .op2rCmp    ; If this op is a comparison
  2855.     cmp.b    #otRevSub,d1
  2856.     seq    revFlg-hbase(A4)
  2857.     bne.s    .o2r2
  2858.     move.b    #otSUB,d1    ; If rev sub, adjust opcode to normal sub
  2859.     clr.w    RevOpnds-hbase(A4)
  2860.  
  2861. .o2r2    move.b    d1,operation-hbase(a4)
  2862.     move.b    opToFrom,d0    ; Is this op chained?
  2863.     bmi.s    .o2r3    ; No
  2864.  
  2865. ; This op is a chained pm-type op.
  2866.  
  2867.     cmp.b    #fchChn,d0    ; Is it chained with a fetched operand?
  2868.     bge    .fchchn
  2869.     move.b    d0,ChnReg-hbase(a4)    ; No
  2870.     backDP
  2871.     cmp.b    #otSUB,d1
  2872.     BNE.S    .chn1    ; Is it subtract (not reversed)?
  2873.     TST.B    revFlg-hbase(A4)
  2874.     BNE.S    .chn1
  2875.     PUSH.L    xchnSub    ; Yes - we need to switch operands.  Compile
  2876.     JSR    comma    ;    sub.l    (a6)+,d1
  2877.             ;    neg.l    d1
  2878.             ; Note: eventually we might have to use
  2879.             ;  ChnReg to get the reg#, as in the FP
  2880.             ;  code below, but at present it must be D1.
  2881.     MOVEQ    #1,D0    ; It was D1 we used
  2882.     BRA    .out
  2883.  
  2884. .chn1    MOVE.B    #1,opReg(A1)
  2885.     MOVE.B    #mdDn,opMode(A1)
  2886.     BSR    newClrOD
  2887.     MOVE.B    #stkpop,opMode
  2888.     BSR    OP2    ;    <op>.l    (a6)+,d1
  2889.             ; Again it must always be D1 at present.
  2890.             ; Note also that if this op is monadic, OP2
  2891.             ;  ignores the A0 descriptor, so that it
  2892.             ;  just compiles
  2893.             ;    <op>.l    d1
  2894.             ;  which is what we want.
  2895.     BSR    releaseOD
  2896.     MOVEQ    #1,D0
  2897.     BRA    .out
  2898.  
  2899. ; Op is chained with a fetched operand.
  2900.  
  2901. .fchchn    and.b    #7,d0    ; Get chain reg #
  2902.     move.b    d0,ChnReg-hbase(a4)
  2903.     move.b    d0,opReg(a1)
  2904.     move.b    #mdDn,opMode(A1)
  2905.     push.l    a1
  2906.     inc.l    #-2,DP    ; Just wipe out the move to the stk.
  2907.     pop.l    a1    ; Everything else was OK already.
  2908.     bra    .out
  2909.  
  2910. ; This op is not chained.  We now look for preceding fetches.
  2911.  
  2912. .o2r3    cmp.b    #otMon,d1    ; If monadic op we only look for 
  2913.     bge.s    .o2r4    ;  one preceding fetch
  2914.     downOD
  2915.     cmp.b    #otFetch,(a0)
  2916.     bne    .noF    ; If no fetch precedes
  2917. .o2r4    downOD
  2918.     cmp.b    #otFetch,(a0)
  2919.     bne.s    .oneF    ; If one fetch
  2920.  
  2921. ; One fetch before a monadic op.  This also used to handle two fetches before
  2922. ; a dyadic, but as they are now already chained to the op, that case shouldn't
  2923. ; arrive here.  But if it does, it might still work.  (Defensive programming?)
  2924.  
  2925.     backDP        ; We recompile as:
  2926.     move.b    reqreg,opToFrom
  2927.     st    ForceToR-hbase(a4)
  2928.     bsr    CompFetch    ;    MOVE.L    <ea>,Dn
  2929.     upOD
  2930.     bra    .callOP2    ;    <OP>.L    Dn
  2931.  
  2932. ; One fetch before a dyadic op, or no fetch before a monadic.
  2933.  
  2934. .oneF    upOD
  2935.     backDP
  2936.     TST.B    revFlg-hbase(A4)    ; Reverse subtract?
  2937.     BNE.S    .revSub1    ; Yes
  2938.     bsr    newOD    ; No.  First we load base for the
  2939.     moveq    #1,d0    ;  fetched operand, since this could
  2940.     bsr    LoadBase    ;  pop something from the stack.
  2941.     MOVE.B    reqreg,D0
  2942.     cmp.b    #mdDn,opMode    ; Does the fetch refer to same Dn?
  2943.     bne.s    .oneF1
  2944.     cmp.b    opReg,d0
  2945.     bne.s    .oneF1
  2946.     UseODsrc
  2947.     move.b    #stkpop,opMode
  2948.     move.b    #Lcode,opSize
  2949.     bsr    OP2    ; Yes.  Compile
  2950.     bsr    ReleaseOD    ;    <OP>.L    <ea>,Dn
  2951.     cmp.b    #otSUB,operation-hbase(a4)
  2952.     bne    .windup
  2953.     move.w    #$4480,d0    ; and if op is subtract, compile
  2954.     or.b    reqreg,d0    ;    NEG.L    Dn
  2955.     push.l    d0
  2956.     jsr    wcomma
  2957.     bra    .windup
  2958.  
  2959.             ; No.  Compile:
  2960. .oneF1    BSR    CompPOPreg    ;    POP.L    Dn
  2961.     BRA.S    .callOP2b    ;    <OP>.L    <ea>,Dn
  2962.  
  2963. .revSub1            ; For rev sub we compile:
  2964.     MOVE.B    reqreg,opToFrom
  2965.     st    ForceToR-hbase(a4)
  2966.     BSR    CompFetch    ;    MOVE.L    <ea>,Dn
  2967.     UseODsrc
  2968.     MOVE.B    #stkpop,opMode
  2969.     MOVE.B    #Lcode,opSize
  2970.     BRA.S    .callOP2    ;    SUB.L    (A6)+,Dn
  2971.  
  2972. ; No fetch precedes.
  2973.  
  2974. .noF
  2975.     upOD
  2976.     backDP
  2977.     cmp.b    #otSUB,operation-hbase(A4)
  2978.     BEQ.S    .sub    ; Is the operation subtract?
  2979. .noF1    MOVE.B    reqReg,D0    ; No.  We'll recompile:
  2980.     BSR    CompPOPreg    ;    POP.L    Dn
  2981.     UseODsrc
  2982.     MOVE.B    #stkpop,opMode
  2983.     MOVE.B    #Lcode,opSize
  2984.     BRA.S    .callOP2    ;    <OP>.L    (A6)+,Dn
  2985.  
  2986.  
  2987. .sub            ; Yes, it's subtract, which isn't
  2988.             ;  commutative.
  2989.     TST.B    revFlg-hbase(A4)    ; Is it actually reverse subtract?
  2990.     BNE.S    .noF1    ; Yes, operands are OK as they are.
  2991.  
  2992.     MOVEQ    #0,D0    ; No - needs special treatment.  We 
  2993.             ;  recompile:
  2994.     BSR    CompPOPreg    ;    POP.L    D0
  2995.     MOVE.B    reqReg,D0
  2996.     BSR    CompPOPreg    ;    POP.L    Dn
  2997.     UseODsrc
  2998.     MOVE.B    #mdDn,opMode
  2999.     MOVE.B    #Lcode,opSize
  3000.     CLR.B    opReg    ;    SUB.L    D0,Dn
  3001.  
  3002. .callOP2
  3003.     BSR    newOD
  3004.     MOVEQ    #1,D0
  3005.     BSR    LoadBase
  3006. .callOP2b
  3007.     BSR    OP2
  3008.     BSR    releaseOD
  3009. .windup    MOVEQ    #0,D0
  3010.     move.b    reqreg,d0
  3011.     CMP.B    #mdAn,opMode(A1)
  3012.     SEQ    D1
  3013.     AND.B    #AnReg,D1
  3014.     OR.B    D1,D0
  3015. .out    BSR    releaseOD
  3016.     MOVEM.L    (A6)+,A0/A1    ; Restore
  3017.     RTS
  3018.  
  3019. .op2rCmp
  3020.     move.b    reqreg,opToFrom    ; Set chain flag in CMP desc
  3021.     clr.b    Rcond-hbase(a4)
  3022.     push.l    a1    ; Save ptr to Dn desc
  3023.     bsr    OptCmp
  3024.     move.l    (a6),a0    ; Recover for Scc compilation
  3025.     bsr    CompScc
  3026.     compopl    xextD1    ; Compile extends to get long boolean
  3027.     pop.l    a1    ; Restore Dn desc ptr ready for windup
  3028.     bra.s    .windup
  3029.  
  3030.  
  3031. ;        ========================
  3032.  
  3033. ;                FPOP2REG
  3034.  
  3035. ;        ========================
  3036.  
  3037. ; FPop2Reg is the floating-point equivalent of Op2Reg.  It recompiles the
  3038. ; A0 FP-op descriptor to an FPn destination.  Leaves D0 with the actual
  3039. ; reg# used.
  3040.  
  3041.     loc
  3042.  
  3043. .chkOpnd
  3044.     ; This is a subroutine to check if one of the operands involved
  3045.     ; in an FPop2Reg is the same as the FPn destination.  If it is, we
  3046.     ; change the destination to FP1.
  3047.         
  3048.     bsr    CmpAddrs
  3049.     bne.s    .coOut
  3050.     move.b    #1,reqreg-hbase(a4)
  3051.     move.b    #mdFPn,opMode(a1)
  3052.     move.b    #fbFP,opFlags
  3053.     move.b    #1,opReg(a1)
  3054. .coOut    rts
  3055.  
  3056. BackToFPDP
  3057.     move.l    opFPDP(a0),d0
  3058.     push.l    a1
  3059.     get.l    DP,d1
  3060.     put.l    d0,DP
  3061.     pop.l    a1
  3062.     rts
  3063.  
  3064. FPop2Reg
  3065.     movem.l    a0/a1,-(a6)    ; Save
  3066.     moveq    #0,d7    ; Will be set NZ if there's an FP temp
  3067.             ;  to dispose at the end
  3068.     move.b    #1,ChnReg-hbase(a4)    ; Chain is normally on FP1 - set as default
  3069.     clr.b    FPdispFlg-hbase(a4)
  3070.     clr.b    FPA-hbase(a4)
  3071.     move.b    d0,reqReg-hbase(A4)
  3072.     bsr    newClrOD    ; Set up a new OD for the FPn dest
  3073.     move.b    #mdFPn,opMode
  3074.     move.b    #fbFP,opFlags
  3075.     move.b    D0,opReg
  3076.     move.l    a0,a1
  3077.     move.l    (a6),a0    ; Recover A0 but leave on stack as well
  3078.     moveq    #0,d0
  3079.     move.b    (a0),d1    ; Opcode to D1
  3080.     btst    #0,1(a0)
  3081.     sne    revFlg-hbase(a4)
  3082.     move.b    d1,operation-hbase(a4)
  3083.     move.b    opToFrom,d0
  3084.     bmi    .fr3
  3085.  
  3086. ; This op is chained.
  3087.  
  3088.     cmp.b    #fchChn,d0    ; Is it chained with a fetched operand?
  3089.     bge    .fchchn    ; Yes
  3090.     move.b    d0,ChnReg-hbase(a4)    ; No
  3091.     move.b    d0,reqreg-hbase(a4)    ; Chain reg# will be the result reg,
  3092.     backDP        ;  unless something happens to change it
  3093.     cmp.b    #otFPmon,operation-hbase(a4)
  3094.     bge    .chnMon
  3095.     move.b    #1,FPdispFlg-hbase(a4)    ; Always an FP temp to dispose
  3096.     cmp.b    #otFPnoncom,operation-hbase(a4)
  3097.     blt    .chn1
  3098.     tst.b    revFlg-hbase(a4)
  3099.     bne    .chn1
  3100.  
  3101. ; Non-commutative and not reversed - we need to switch operands.  Current
  3102. ; chain reg # is still in D0.
  3103.  
  3104.     eor.b    #1,d0    ; Compile:
  3105.     push.w    d0
  3106.     bsr    compPopFPn    ;    pop sequence to "other" FP reg FPn
  3107.     moveq    #0,d0
  3108.     move.b    Operation,d0    ;    Fxxx    FPm,FPn
  3109.     lsl.w    #2,d0
  3110.     lea    xFPops-((otFPops)*4),a2
  3111.     move.l    0(a2,d0.w),d0
  3112.     pop.w    d2    ; Dest reg#
  3113.     moveq    #0,d1
  3114.     move.b    ChnReg,d1    ; Source reg#
  3115.     move.b    d2,ChnReg-hbase(a4)    ; Changing chain to "other" reg
  3116.     move.b    d2,reqreg-hbase(a4)    ; and the result will be there too
  3117.     lsl.w    #3,d1
  3118.     or.w    d2,d1
  3119.     lsl.w    #7,d1
  3120.     or.w    d1,d0
  3121.     push.l    d0
  3122.     jsr    comma
  3123.     bsr    chkFPdisp
  3124.     bra    .frEnd
  3125.  
  3126. ; Commutative, or non-com but reversed.  We can leave the operands as
  3127. ; they are.  Chain reg# is in D0.
  3128.  
  3129. .chn1    move.b    d0,opReg(a1)
  3130.     move.b    #mdFPn,opMode(a1)
  3131.     move.b    #fbFP,opFlags(a1)
  3132.     bsr    newClrOD
  3133.     move.b    #stkpop,opMode
  3134.     clr.b    FPA-hbase(a4)
  3135.     bsr    OP2    ; Compile the right sequence, we hope
  3136.     bsr    releaseOD
  3137.     bra    .frEnd
  3138.  
  3139. ; Op is monadic and chained.
  3140.  
  3141. .chnMon
  3142.     move.b    d0,opReg(a1)    ; We're going to operate on the chain reg
  3143.     move.b    d0,reqreg-hbase(a4)    ; So that's where the result will be
  3144.     move.b    #mdFPn,opMode(a1)
  3145.     move.b    #fbFP,opFlags(a1)
  3146.     move.l    a1,a0    ; Source and dest are both FPn, the chain reg.
  3147.     bsr    OP2    ; Compile the op
  3148.     bra    .frEnd
  3149.  
  3150. ; Op is chained with a fetched operand.
  3151.  
  3152. .fchchn    and.b    #7,d0
  3153.     move.b    d0,ChnReg-hbase(a4)
  3154.     move.b    d0,reqreg-hbase(a4)
  3155.     move.b    d0,opReg(a1)
  3156.     move.b    #mdFPn,opMode(a1)
  3157.     move.b    #fbFP,opFlags(a1)
  3158.     bsr    BackToFPDP
  3159.     bra    .frEnd
  3160.  
  3161. ; This op is not chained.  We now look for preceding fetches.  Opcode is in D1.
  3162.  
  3163. .fr3    cmp.b    #otFPmon,d1    ; If monadic op we only look for 
  3164.     bge    .frMonChk    ;  one preceding fetch
  3165.     downOD
  3166.     cmp.b    #otFetch,(a0)
  3167.     bne    .noF    ; If no fetch precedes
  3168.  
  3169. ; One fetch before a dyadic op.
  3170.  
  3171. ;    bsr.s    .chkOpnd    ; %%%%
  3172.     backDP
  3173.     btst    #flFP,opFlags
  3174.     bne.s    .fr4
  3175.     st    FPdispFlg-hbase(a4)    ; 2 to dispose
  3176.     bra.s    .fr5
  3177. .fr4    move.b    #1,FPdispFlg-hbase(a4)    ; 1 to dispose.
  3178. .fr5    tst.b    revFlg-hbase(A4)    ; Reversed op?
  3179.     bne.s    .rev1    ; Yes
  3180.     bsr    newOD    ; No. First load base for fetched operand
  3181.     moveq    #1,d0
  3182.     bsr    LoadBase
  3183.     move.b    reqreg,d0
  3184.     cmp.b    #mdFPn,opMode    ; %%%start
  3185.     bne.s    .oneF1
  3186.     cmp.b    opReg,d0
  3187.     bne.s    .oneF1
  3188.     cmp.b    #otFPnoncom,operation-hbase(a4)
  3189.     blt    .stkSrc    ; Compile
  3190.             ;    (pop FP heap to An)
  3191.             ;    <FOP>    (An),FPn
  3192.  
  3193.     moveq    #1,d0
  3194.     move.b    d0,reqreg-hbase(a4)
  3195.     move.b    #mdFPn,opMode(a1)
  3196.     move.b    #fbFP,opFlags(a1)
  3197.     move.b    d0,opReg(a1)
  3198.  
  3199. .oneF1            ; Otherwise compile
  3200.     bsr    CompPopFPn    ;    (pop FP heap to FPn)
  3201.     bra    .callOP2b    ;    <FOP>    <ea>,FPn
  3202.  
  3203. .rev1            ; For reversed op we recompile:
  3204.     move.b    reqreg,d0
  3205.     bsr    CompMoveToFPn    ;    FMOVE.L    <ea>,FPn (or equivalent)
  3206.     UseODsrc
  3207.     move.b    #stkpop,opMode    ;    (pop FP heap addr to a0)
  3208.     move.b    #1,opind
  3209.     clr.b    FPA-hbase(a4)
  3210.     bra    .callOP2    ;    <FOP>    (a0),FPn
  3211.  
  3212. ; No fetch precedes.
  3213.  
  3214. .noF    upOD
  3215.     backDP
  3216.     st    FPdispFlg-hbase(a4)    ; There will be two to dispose
  3217.     cmp.b    #otFPnoncom,operation-hbase(a4)
  3218.     blt.s    .nf1
  3219.     tst.b    revFlg-hbase(a4)
  3220.     bne.s    .nf1
  3221.  
  3222. ; Not commutative and not reversed.  We need to juggle.
  3223.  
  3224.     moveq    #0,d0
  3225.     bsr    CompPopFPn
  3226.     move.b    #1,FPA-hbase(a4)
  3227.     move.b    reqreg,d0
  3228.     bsr    CompPopFPn
  3229.     UseODsrc
  3230.     move.b    #mdFPn,opMode
  3231.     move.b    #fbFP,opFlags
  3232.     clr.b    opReg
  3233.     clr.b    reqreg-hbase(a4)    ; Result will be in FP0
  3234.     bra.s    .callOP2
  3235.  
  3236. ; Commutative, or non-com but reversed.  Operands are OK as they are.
  3237.  
  3238. .nf1    move.b    FPA,d0
  3239.     move.b    reqreg,d0
  3240.     bsr    CompPopFPn
  3241. .stkSrc    UseODsrc
  3242.     move.b    #stkpop,opMode
  3243.  
  3244. .callOP2            ; Remember to set FPA appropriately before
  3245.             ; coming here!
  3246.     bsr    newOD
  3247.     move.b    FPA,D0
  3248.     bsr    LoadBase
  3249. .callOP2b
  3250.     bsr    OP2
  3251.     bsr    releaseOD
  3252.  
  3253. .frEnd    bsr    releaseOD
  3254.     moveq    #0,d0
  3255.     move.b    reqreg,d0    ; Reqreg will have been changed appropriately
  3256.             ;  if we used a different reg than the one
  3257.             ;  requested.
  3258.  
  3259.     movem.l    (a6)+,a0/a1    ; Restore
  3260.     rts
  3261.  
  3262. ; This is a monadic op.
  3263.  
  3264. .frMonChk
  3265.     downOD
  3266.     cmp.b    #otFetch,(a0)
  3267.     bne.s    .frMonNoF
  3268.  
  3269. ; One fetch before a monadic op.  We can absorb the fetch into the operation.
  3270.  
  3271.     backDP
  3272. ;    move.b    reqreg,d0
  3273. ;    bsr    CompMoveToFPn
  3274.  
  3275.     move.l    a0,a1
  3276.     bsr    newClrOD
  3277.     move.b    #mdFPn,opMode
  3278.     move.b    #fbFP,opFlags
  3279.     move.b    reqreg,opReg
  3280.     exg    a0,a1
  3281.     bsr    OP2    ;    <FOP>    <ea>,FPn
  3282.     bsr    releaseOD
  3283.     bra    .frEnd
  3284.  
  3285. ; No fetch before a monadic op.
  3286.  
  3287. .frMonNoF
  3288.     upOD
  3289.     backDP
  3290.     bsr    newClrOD
  3291.     move.b    #mdFPn,opMode
  3292.     move.b    #fbFP,opFlags
  3293.     move.b    reqreg,opReg
  3294.     move.l    a0,a1
  3295.     bsr    newClrOD
  3296.     move.b    #stkPop,opMode
  3297.     move.b    #1,opind
  3298.     bsr    OP2    ;    <FOP>    <ea>,FPn
  3299.     bsr    releaseOD
  3300.     bsr    releaseOD
  3301.     bra    .frEnd
  3302.  
  3303.  
  3304. ;        ============================
  3305.  
  3306. ;                GETBASE etc.
  3307.  
  3308. ;        ============================
  3309.  
  3310. ; GetBase converts the address in D0 to base-displacement form.
  3311. ; At this stage we maintain a couple of abstractions - we use A3 (lobase)
  3312. ; for all main dictionary references, and A5 for modules, and we keep a
  3313. ; 4-byte displacement.  We defer the decision as to whether we'll actually
  3314. ; use A4 (hibase) for a main dic reference until the final code generation,
  3315. ; since the displacement may be modified first, which could change things.
  3316.  
  3317. ; We leave the base reg # in D1, and the displacement in D0.  Other regs preserved.
  3318.  
  3319.     loc
  3320. getBase
  3321.     push.l    a1    ; Save A1
  3322.     get.L    MBcomp,a1    ; Modbase value for compilation to A1
  3323.     move.l    d0,d1
  3324.     add.l    #32766,d1
  3325.     cmp.l    a1,d1
  3326.     bhs.s    .gbMod    ; No - use modbase
  3327.  
  3328.     get.L    State,D1    ; Are we in compile state,
  3329.     beq.s    .gb1
  3330.     get.L    SAcomp,D1    ; and compiling stand-alone code?
  3331.     BNE.S    .SAfail    ; Yes - fail - can't ref main dic from there
  3332.  
  3333. .gb1    sub.l    a3,d0    ; No.  Make displ relative to lobase
  3334.     moveq    #3,d1
  3335.     bra.s    .gbOut
  3336.  
  3337. .gbMod    sub.l    a1,d0
  3338.     moveq    #5,d1
  3339.  
  3340. .gbOut    pop.l    a1    ; Restore A1
  3341.     rts        ;  and get out.
  3342.  
  3343. .SAfail    move.l    #160,d0    ; "You can't refer to the main dic from
  3344.     bra    hndErr    ;  stand-alone code"
  3345.  
  3346.  
  3347. ; setAddr ( addr -- )  Sets up the A0 descriptor with the corresponding base
  3348. ; and displacement.
  3349.  
  3350.     loc
  3351. setAddr    pop.l    d0
  3352.     move.l    d0,opAddr
  3353.     bsr.s    getBase
  3354.     bset    #6,d1
  3355.     move.b    d1,opBreg
  3356.     move.l    d0,opDispl
  3357.     move.b    #mdBD,opMode
  3358.     move.b    #1,opind    ; This is usually what we want
  3359.     rts
  3360.  
  3361.  
  3362. ; offsetAddr applies the offset in D0 to the address in the A0 descriptor,
  3363. ; modifying the descriptor as necessary.  It's not very complicated now, but
  3364. ; it used to have to check for a base reg change.
  3365.  
  3366. offsetAddr
  3367.     add.l    d0,opDispl
  3368.     add.l    d0,opAddr
  3369.     rts
  3370.  
  3371.     loc
  3372.  
  3373. ; GetRealBase is called to adjust a "virtual" base reg to the real one
  3374. ; once actual code is to be compiled.
  3375.  
  3376. ; Entered with D0 and D1 as returned from a GetBase call, i.e.
  3377. ; D0 = displacement, D1 = virtual base.  Also D2 = absolute address.
  3378.  
  3379. ; Returns D0 = displacement, D1 = real base.  Leaves CC = NE if the result
  3380. ; can't be compiled into a single instruction.  These cases are:
  3381. ; 1. The displacement is too big for 16 bits.
  3382. ; 2. The base specified is modbase (A5) but the use of modbase has been
  3383. ;    inhibited by InhibitMB?.
  3384.  
  3385. GetRealBase
  3386.     movem.l    d3/a1,-(a6)    ; Save regs
  3387.     cmp.b    #3,d1
  3388.     beq.s    .grbMainDic
  3389.     cmp.b    #4,d1    ; Virtual base shouldn't really be A4, but
  3390.     beq.s    .grbMainDic    ;  this will get the right answer if it is.
  3391.     cmp.b    #5,d1
  3392.     bne.s    .grbWC    ; If some other base reg, leave alone and just
  3393.             ;  check the displ for range.
  3394.     get.l    inhibitMBq,d3    ; It's A5. If usage isn't inhibited,
  3395.             ;  range chk and out.
  3396.     beq.s    .grbWC
  3397.     moveq    #noReg,d1    ; If it is, return "no reg" and CC = NE.
  3398.     bra.s    .grbOut
  3399.  
  3400. .grbWC    bsr    WdChk
  3401. .grbOut    movem.l    (a6)+,d3/a1    ; Restore regs (preserves CC)
  3402.     rts
  3403.  
  3404. .grbMainDic
  3405.     lea    32766(a3),a1
  3406.     cmp.l    a1,d2
  3407.     bhs.s    .grbUseHB
  3408.     moveq    #3,d1
  3409.     move    #4,ccr    ; Use lobase.  Set CC EQ.
  3410.     bra.s    .grbOut
  3411.  
  3412. .grbUseHB            ; Use hibase.
  3413.     move.l    d2,d0
  3414.     sub.l    savedA4,d0
  3415.     moveq    #4,d1
  3416.     bra.s    .grbWC    ; Leave CC EQ if OK, NE if out of range
  3417.  
  3418.  
  3419. ;    ========================
  3420.  
  3421. OpAndAddr    ; ( addr -- )  Opcode is in D0.
  3422.     MOVE.L    D0,D6    ; Opcode
  3423.     BSR    initODs
  3424.     BSR    setAddr
  3425.     moveq    #0,d0
  3426.     bsr    loadbase
  3427.     MOVE.L    D6,D0
  3428.     BRA    CompMOp2    ; Note: assumes Size bits OK already
  3429.  
  3430.  
  3431. ;        ==========================
  3432.  
  3433. ;                 COMPJSR
  3434.  
  3435. ;        ==========================
  3436.  
  3437. ; COMPJSR ( addr -- )  is the basic routine to compile a plain vanilla call
  3438. ; to a non-inline Mops word.  For efficiency, we use BSR short form if we can.
  3439. ; If the target is too far away, we try to use an An-relative JSR, which
  3440. ; simplifies code movement.  But if the target is outside base addressing
  3441. ; range, we can't do that, so we try to generate a long BSR.  If all else
  3442. ; fails we use an index-mode JSR.
  3443.  
  3444.     loc
  3445. compJSR
  3446.     st    d0    ; True means we push the JSR desc at the end
  3447.     BSR    initODs
  3448.  
  3449. .cj0    lea    ODnew,a0
  3450. .cjDP            ; CompJSRnoPush comes in here
  3451.     movem.l    d3-d7,-(a7)    ; Save
  3452.     move.b    d0,d3    ; Transfer push flag to D3
  3453.     get.L    dp,d0
  3454.     bsr    GetBase    ; Get base for where we are now
  3455.     move.b    d1,d4    ; Save in d4
  3456.     move.l    (a6),d0
  3457.     bsr    GetBase    ; Get base for target
  3458.     move.b    d1,d7    ; Save base in d7
  3459.     move.l    d0,d6    ;  and displacement in d6
  3460.     cmp.b    d1,d4    ; Compare dic segments
  3461.     bne.s    .jsr    ; If different, can't use BSR!!
  3462.  
  3463. .cjBsr    compop    xbsr    ; We'll try for a short BSR first
  3464.     move.l    (a6),d5    ; dest addr
  3465.     get.L    dp,D0
  3466.     sub.l    d0,d5    ; Branch offset to D5
  3467.     cmpi.l    #-128,d1    ; Can we do a short BSR?
  3468.     blt.s    .long    ; No
  3469.     cmp.l    #128,d1
  3470.     bge.s    .long    ; No
  3471.     addq    #4,A6    ; Yes
  3472.     get.B    fmkCnt,D2
  3473.     put.B    D2,callOut
  3474.     move.l    d0,a0
  3475.     move.b    d1,-1(a0)
  3476.     bra.s    .cjEnd
  3477.  
  3478. ; We're out of range of a short branch.  We try for an An-relative JSR.
  3479.  
  3480. .long    move.l    d6,d0
  3481.     move.b    d7,d1
  3482.     move.l    (a6),d2
  3483.     bsr    getRealBase    ; Can we do it?
  3484.     bne.s    .cjPC    ; No
  3485.  
  3486. .toJSR    inc.L    #-2,dp    ; Yes.  Wipe BSR and fall thru
  3487.         ;  to JSR code.
  3488. .jsr    move.b    #mdBD,opMode
  3489.     move.b    #1,opind
  3490.     bset    #6,d7
  3491.     move.b    d7,opBreg
  3492.     move.l    d6,opDispl
  3493.     move.l    (a6)+,opAddr
  3494.     bsr    newOD
  3495.     moveq    #1,d0    ; We'll LoadBase to A1, since if this
  3496.     bsr    loadbase    ;  is a method call, ^obj will be in A0 (the
  3497.     move.w    #$4E80,d0    ;  voice of experience)
  3498.     bsr    CompMOp2
  3499.     bsr    releaseOD
  3500.     bra.s    .cjEnd
  3501.  
  3502. .cjPC    move.l    d5,d0    ; Can't do An-rel JSR.
  3503.     bsr    WdChk    ; Can we do PC-rel BSR?
  3504.     bne.s    .toJSR    ; No - do JSR anyway, as LoadBase will
  3505.         ;  convert to index mode.
  3506.     addq    #4,a6    ; Yes
  3507.     push.l    d5
  3508.     jsr    wcomma
  3509.     get.B    fmkCnt,D2
  3510.     put.B    D2,callOut
  3511.  
  3512. .cjEnd    tst.b    d3
  3513.     beq.s    .noPush
  3514.     movem.l    (a7)+,d3-d7    ; Restore
  3515.     get.W    saveTandS,D0
  3516.     bne.s    .getout
  3517.     lea    ODnew,a0
  3518.     btst    #flFP,opFlags
  3519.     bne.s    .psh
  3520.     move.b    #otJSR,(a0)    ; If not a FP op, force desc type to JSR
  3521. .psh    bra    pushOD
  3522.  
  3523. .noPush    movem.l    (a7)+,d3-d7
  3524. .getout    rts
  3525.  
  3526. CompJSRnoPush        ; As for CompJSR, but uses the a temp desc rather
  3527.     move.l    a0,-(a7)    ; than ODnew, and doesn't push the JSR desc.
  3528.     bsr    newOD
  3529.     sf    d0
  3530.     bsr    .cjDP
  3531.     bsr    releaseOD
  3532.     move.l    (a7)+,a0
  3533.     rts
  3534.  
  3535. CompJsrLong
  3536.     MOVE.W    #$4E80,D0
  3537.     BSR    OpAndAddr
  3538.     bra.s    .cjEnd
  3539.  
  3540.  
  3541. ; hPatch ( newCfa oldCfa -- ) is called to handle a FORWARD definition.
  3542. ; It compiles a JMP to newCfa at oldCfa, so that a call to oldCfa will
  3543. ; in fact execute newCfa.  10 bytes must be available at oldCfa to
  3544. ; accommodate the longest JMP sequence.
  3545.  
  3546. hPatch
  3547.     get.l    dp,-(a7)    ; Save DP
  3548.     put.l    (a6)+,dp    ; Set DP to oldCfa
  3549.     move.w    #$4EC0,d0    ; Compile a JMP to newCfa there
  3550.     bsr    OpAndAddr
  3551.     put.l    (a7)+,dp    ; Restore DP
  3552.     rts
  3553.  
  3554.  
  3555. ; JSRtoJMP recompiles a JSR as a JMP, or a BSR as a BRA.
  3556. ; Leaves CC NE if succeeded.  If the instruction at opDP isn't
  3557. ; a JSR or BSR, we assume we have a more complex sequence (which
  3558. ; can happen if we're outside normal addressing range.  We don't
  3559. ; do anything in this case, but return CC EQ.
  3560.  
  3561. JSRtoJMP
  3562.     loc
  3563.     move.l    opDP,a1
  3564.     move.w    (a1),d0
  3565.     and.w    #$FFC0,d0
  3566.     cmp.w    #$4E80,d0
  3567.     beq.s    .jsr
  3568.     and.w    #$FF00,d0
  3569.     cmp.w    #$6100,d0
  3570.     beq.s    .bsr
  3571.     move    #4,ccr
  3572.     rts        ; Return with CC EQ
  3573.  
  3574. .jsr    or.b    #$40,1(A1)
  3575.     rts        ; Return with CC NE
  3576.  
  3577. .bsr    move.b    #$60,(a1)
  3578.     rts        ; Ditto
  3579.  
  3580.  
  3581. ;        =============================
  3582.  
  3583. ;        COMPILATION OF ENTRY AND EXIT
  3584.  
  3585. ;        =============================
  3586.  
  3587. hmentry
  3588.     PUSH.L    xMentry
  3589.     JSR    comma
  3590.     RTS
  3591.  
  3592.     loc
  3593.  
  3594. XLdispl    long
  3595. XLeaBits    word
  3596. numLoc    long
  3597. numPLadj    long
  3598. RegNumAdjustment
  3599.     long
  3600.  
  3601. ; FPadjust is a utility routine to adjust the #PL count in D6 - if we're compiling FPU
  3602. ; code, FP locals will go to the FP regs (or as many as possible will, anyway).
  3603. ; This will free up some D regs, in effect reducing the value of #PL which is used
  3604. ; to calculate the register allocation.
  3605. ; This routine also sets RegNumAdjustment to the (positive) value by which #PL is
  3606. ; reduced.
  3607. ; Uses D0-D4.
  3608.  
  3609. FPadjust
  3610.     clr.l    RegNumAdjustment-hbase(a4)
  3611.     get.l    useFPUq,d0
  3612.     beq.s    .fpaOut
  3613.     get.l    FltFlg,d4
  3614.     move.l    d6,d1
  3615.     move.l    numLoc,d3
  3616.     beq.s    .fpaOut
  3617.     moveq    #6,d2
  3618.     bra.s    .fpaLpTst
  3619.  
  3620. .fpaLoop
  3621.     lsr.l    #1,d4
  3622.     bcc.s    .fpaLpTst
  3623.     subq.l    #1,d6
  3624.     subq    #1,d2
  3625.     beq.s    .fpaOut
  3626. .fpaLpTst
  3627.     dbra    d3,.fpaLoop
  3628.     sub.l    d6,d1
  3629.     move.l    d1,RegNumAdjustment-hbase(a4)
  3630. .fpaOut    rts
  3631.  
  3632.  
  3633. ; PLentry calls HPLentry.  This compiles the entry sequence for a word or method
  3634. ; with named parameters and/or local variables.  It uses the values #P (the number
  3635. ; of parameters), #PL (the total number of parameters plus locals), #F (the number
  3636. ; of floating parms/locals) and FltFlg (a 4-byte indicator of which parms/locals
  3637. ; are floating, one bit for each one).
  3638.  
  3639. hplentry
  3640.     get.l    numPL,d6    ; D6 = numPL
  3641.     get.l    numP,d5    ; D5 = numP
  3642.     move.l    d6,d0
  3643.     sub.l    d5,d0    ; Work out number of locals
  3644.     move.l    d0,numLoc-hbase(a4)    ;  and save it
  3645.     bsr    FPadjust    ; Adjust D6 if necessary
  3646.     move.l    d6,numPLadj-hbase(a4)
  3647.  
  3648. ; Save phase.  Here we compile code to save all the regs and XL locations we need,
  3649. ; on the return stack.
  3650.  
  3651.     moveq    #0,d4    ; D4 will hold no of ExtraLocals (XL) locations
  3652.     moveq    #4,d2
  3653.     sub.l    d6,d2    ; D2 = number of unused reg slots
  3654.     bpl.s    .sp1    ; Positive - we won't be using the XL area
  3655.             ; We will be using the XL area.
  3656.     sub.l    d2,d4    ; D4 = number of XL locations
  3657.     moveq    #0,d2    ; No unused reg slots
  3658.     cmp.b    #3,d4    ; Is # XL locns gtr than 3?
  3659.     ble.s    .sp1    ; No - no need to save D3
  3660.     move.w    #$F8,d1    ; Yes - include D3 in initial reg save mask
  3661.     bra.s    .sp2
  3662.  
  3663. .sp1    move.w    #$F0,d1    ; No need to save D3, so here we don't
  3664.             ;  include it in initial reg save mask.
  3665. .sp2    move.w    d1,d0
  3666.     lsr.w    d2,d0
  3667.     and.w    d0,d1
  3668.     moveq    #$27,d0    ; ea bits for -(a7)
  3669.     moveq    #2,d2    ; Predecrement, reg to mem
  3670.     bsr    compMOVEM    ;    movem.l    <regs>,-(a7)
  3671.     tst.w    d4
  3672.     beq.s    .spsvF
  3673.     lea    XLOD,a0
  3674.     move.l    d4,d0
  3675.     asl.l    #2,d0
  3676.     add.l    XLDispl,d0
  3677.     move.l    d0,opDispl
  3678.  
  3679. .spXLloop            ; Loop to move XL locations to rtn stack,
  3680.     move.w    #$3FF,d1    ; 10 at a time.  Initial reg save mask to D1,
  3681.             ;  specifying D0-D7/A0/A1
  3682.     sub.w    #10,d4
  3683.     bgt.s    .spx1
  3684.             ; Last time round.
  3685.     move.l    XLdispl,opDispl    ; Restore opDispl of XL start for source
  3686.     cmp.w    #-9,d4    ; Only one left?
  3687.     beq.s    .spMv1    ; Yes
  3688.     move.w    d4,d2    ; No
  3689.     neg.w    d2
  3690.     lsr.w    d2,d1    ; Adjust MOVEM mask
  3691.     bra.s    .spx2
  3692.  
  3693. .spMv1    move.w    XLeaBits,d0    ; Only 1 to be moved - use MOVE instead
  3694.     or.w    #$2F00,d0    ;  of MOVEM
  3695.     push.l    d0
  3696.     jsr    wcomma
  3697.     bsr    CompExt
  3698.     bra.s    .spsvF
  3699.  
  3700. .spx1    sub.l    #40,opDispl    ; Not last time.  Decrement XL addr by 40.
  3701. .spx2    move.w    XLeaBits,d0
  3702.     moveq    #1,d2
  3703.     bsr    CompMOVEM    ;    movem.l    <XL+n>,d0-d7/a0/a1
  3704.     moveq    #$27,d0    ; ea bits for -(a7)
  3705.     moveq    #2,d2    ; Predecrement, reg to mem 
  3706.     bsr    compMOVEM    ;    movem.l    d0-d0/a0/a1,-(a7)
  3707.     tst.w    d4
  3708.     bgt.s    .spXLloop
  3709.  
  3710. .spsvF    get.l    useFPUq,d0    ; Now we save the FP regs we need.
  3711.     beq.s    .parmPhase    ; Skip this if not compiling FPU code
  3712.     get.l    numF,d0    ; Or if no floating parms/locals
  3713.     beq.s    .parmPhase
  3714.     move.w    #$FC,d1    ; fmovem mask for FP2-FP7
  3715.     moveq    #6,d2
  3716.     sub.w    d0,d2    ; Work out how many we really need to save
  3717.     ble.s    .spsvFmany    ; If all
  3718.     move.w    d1,d0    ; Not all - shift and mask the mask
  3719.     lsr.w    d2,d0
  3720.     and.w    d0,d1
  3721.     bsr    LowBit
  3722.     blt.s    .spsvFone
  3723. .spsvFmany
  3724.     move.l    #$F227E000,d0    ;    fmovem    <regs>,-(a7)
  3725.     or.w    d1,d0
  3726.     push.l    d0
  3727.     jsr    comma
  3728.     bra.s    .parmPhase
  3729.  
  3730. .spsvFone
  3731.     push.l    #$F2276900,d0    ;    fmove.x    FP2,-(a7)
  3732.     jsr    comma
  3733.  
  3734. ; Parm phase.  Here we compile code to move the stack parms into the regs and/or
  3735. ; the XL area.
  3736.  
  3737. .parmPhase
  3738.     tst.w    d5    ; Test #P
  3739.     beq    .ppinitF    ; If no parms, skip this
  3740.     move.w    d6,d4
  3741.     sub.w    d5,d4    ; D4 = # locals
  3742.     subq.w    #4,d4
  3743.     bge    .pp2    ; If locals will use all the regs
  3744.     move.w    #$F00,d1
  3745.     neg.w    d4    ; D4 = # D regs available for parms
  3746.     lsr.w    d4,d1
  3747.     and.w    #$FF,d1    ; Form reg mask for those regs
  3748.     move.w    d4,d0
  3749.     sub.w    d5,d0    ; Check how many we really need
  3750.     ble.s    .pp1
  3751.     move.w    #$F0,d2    ; If not all, mask out the ones we don't need
  3752.     lsr.w    d0,d2
  3753.     and.w    d2,d1
  3754.             ; Final mask is in D1.
  3755. .pp1    moveq    #$1E,d0    ; ea bits for (a6)+
  3756.     moveq    #1,d2    ; not predecrement, mem to reg
  3757.     bsr    CompMOVEM    ;    movem.l    (a6)+,<regs>
  3758.     move.w    d5,d0
  3759.     sub.w    d4,d0    ; D0 = # parms going to XL area
  3760.     ble.s    .ppinitF    ; If none
  3761.     move.w    d0,d4
  3762. .ppXLloop            ; Loop to pop parms to XL locations,
  3763.     move.w    #$30F,d1    ; 6 at a time - that's how many regs we have
  3764.     sub.w    #6,d4    ;  available for scratch use.  If we need 4 or
  3765.             ;  more XL locations D3 will have been saved,
  3766.             ;  and so is available here.
  3767.     bgt.s    .ppx1
  3768.             ; Last time round.
  3769.     cmp.w    #-5,d4    ; Only one left?
  3770.     beq.s    .ppMv1    ; Yes
  3771.     move.w    d4,d2    ; No
  3772.     neg.w    d2
  3773.     move.w    #$33F,d3
  3774.     lsr.w    d2,d3    ; Adjust MOVEM mask - as the number of regs to
  3775.     and.w    d3,d1    ;  be moved gets less, we omit A1, then A0,
  3776.     bra.s    .ppx1    ;  then D3, then D2.  At least D0 and D1 must
  3777.             ;  be moved, or we wouldn't have got here!
  3778.  
  3779. .ppMv1    move.w    XLeaBits,d0    ; Only 1 to be moved - use MOVE instead
  3780.     move.l    d0,d1    ;  of MOVEM
  3781.     and    #7,d0
  3782.     lsl    #6,d0
  3783.     and    #$38,d1
  3784.     or    d1,d0
  3785.     lsl    #3,d0
  3786.     or.w    #$201E,d0
  3787.     push.l    d0
  3788.     jsr    wcomma
  3789.     bsr    CompExt
  3790.     bra.s    .ppinitF
  3791.  
  3792. .ppx1    moveq    #$1E,d0    ; ea bits for (a6)+
  3793.     moveq    #1,d2    ; not predecrement, mem to reg
  3794.     bsr    CompMOVEM    ;    movem.l    (a6)+,d0-d2/a0/a1
  3795.     move.w    XLeaBits,d0
  3796.     moveq    #0,d2    ; Not predecrement, reg to mem
  3797.     bsr    compMOVEM    ;    movem.l    d0-d2/a0/a1,<XL+n>
  3798.     add.l    #24,opDispl    ; Increment XL displ by 6*4 = 24
  3799.     tst.w    d4
  3800.     bgt.s    .ppXLloop
  3801.     bra.s    .ppinitF
  3802.  
  3803. .pp2    asl.w    #2,d4    ; We come here if all regs are in use for locals.
  3804.     ext.l    d4
  3805.     add.l    d4,opDispl    ; Update opDispl to 1st XL locn for parms
  3806.     move.w    d5,d4
  3807.     bra    .ppXLloop    ; Go to loop to move parms to XL area.
  3808.  
  3809. ; Now we compile code to initialize any floating point parms or locals.
  3810. ; For non-FPU code, floating locals are cleared.  For FPU code, floating
  3811. ; parms have to be moved to the FP regs.
  3812.  
  3813. .ppinitF
  3814.     get.l    numPL,d1    ; Unadjusted #parms/locals to d1 for loop count
  3815.     move.l    numLoc,d2    ; # locals to d2
  3816.     moveq    #4,d3    ; d3 will keep track of D reg usage
  3817.     moveq    #1,d7    ; d7 will keep track of FP reg usage
  3818.     get.l    FltFlg,d4    ; FltFlg has a bit for every floating p/l
  3819.  
  3820. .ppFloop
  3821.     lsr.l    #1,d4    ; Is next p/l floating?
  3822.     bcc.s    .ppFlptst    ; No
  3823.     get.l    UseFPUq,d0    ; Yes.  Using FPU?
  3824.     bne    .ppFPU    ; Yes
  3825. .notFPn    tst.w    d2    ; No.  Are we still doing locals?
  3826.     bgt.s    .clear    ; Yes - clear this one
  3827.  
  3828. .ppFlptst            ; Test for loop end:
  3829.     addq    #1,d3    ; Update D reg #
  3830. .ppFlptst1            ; FPU local code comes in here - D reg not
  3831.             ;  used for FP local if FP reg is available.
  3832.     subq    #1,d2
  3833.     subq    #1,d1    ; Any parms/locals left?
  3834.     bgt.s    .ppFloop    ; If so, loop
  3835. .ppOut    rts
  3836.  
  3837. .clear    move.l    d3,d0    ; Get D reg #
  3838.     subq.l    #8,d0    ; If >= 8, it's really in the XL area
  3839.     bge.s    .clXL
  3840.     move    d3,d0
  3841.     moveq    #0,d1
  3842.     bsr    CompMoveq    ;    moveq    #0,Dn
  3843.     bra.s    .ppFlptst
  3844.  
  3845. .clXL    asl.l    #2,d0    ; Local is in XL area.
  3846.     add.l    XLdispl,d0    ; Work out right opDispl
  3847.     move.l    d0,opDIspl
  3848.     move.w    XLeaBits,d0
  3849.     or.w    #$4280,d0
  3850.     push.l    d0
  3851.     bsr    wcomma    ;    clr.l    <ea>
  3852.     bsr    compExt
  3853.     bra.s    .ppFlptst
  3854.  
  3855. .ppFPU    addq.w    #1,d7    ; We're compiling FPU code.
  3856.     cmp.w    #7,d7    ; Any FP regs left?
  3857.     bgt    .notFPn    ; No - handle as if non-FPU code.
  3858.     tst.w    d2    ; Yes.  Doing parms yet?
  3859.     bgt    .ppFlptst1    ; No - nothing to do.
  3860.     movem.l    d1-d4,-(a6)    ; Yes - save regs
  3861.     bsr    newClrOD    ; Parm to be moved to FPn.
  3862.     move.b    #mdFPn,opMode    ; New temp OD for FPn
  3863.     move.b    #fbFP,opFlags
  3864.     move.b    d7,opReg    ; Set FP reg #
  3865.     move.l    a0,a1
  3866.     clr.b    FPA-hbase(a4)
  3867.     move.l    d3,d0    ; Get D reg number for parm
  3868.     subq.l    #8,d0    ; If >= 8, it's really in the XL area
  3869.     bge.s    .ppFPXL
  3870.     bsr    newClrOD
  3871.     move.b    #mdDn,opMode
  3872.     move.b    #1,opind
  3873.     move.b    d3,opReg
  3874.     bsr    CompMove    ; Move operand to FPn
  3875.     bsr    releaseOD
  3876.     bsr    releaseOD
  3877. .ppFPrstr
  3878.     movem.l    (a6)+,d1-d4
  3879.     bra    .ppFlptst
  3880.  
  3881. .ppFPXL    lea    XLOD,a0
  3882.     asl.l    #2,d0
  3883.     add.l    XLdispl,d0
  3884.     move.l    d0,opDIspl
  3885.     bsr    CompMove
  3886.     bsr    releaseOD
  3887.     bra.s    .ppFPrstr
  3888.  
  3889.  
  3890. ;    ============ Compilation of exit =============
  3891.  
  3892. ; This code is basically the reverse of the save phase above.  It restores everything
  3893. ; that got saved.
  3894.  
  3895. rstRegMask    word
  3896.  
  3897. CompExit
  3898.     get.l    localq,D0    ; Skip the following if we're in a local
  3899.     bne    .ce1    ;  section
  3900.     get.l    numPL,d0
  3901.     beq    .ce1    ; Or if there are'nt any parms/locals
  3902.  
  3903.     get.L    FltFlg,d1    ; FltFlg marks any floating parms/locals
  3904.     beq.s    .ceFPrst    ; Skip this if none
  3905.     get.l    useFPUq,d0
  3906.     bne.s    .ceFPU    ; If we're compiling FPU code, special 
  3907.             ;  treatment
  3908.  
  3909. ; Now we dispose of floating heap locations.
  3910.  
  3911. .ceDsp    lea    ODnew,a0
  3912.     bsr    ClearOD
  3913.     move.b    #mdLit,opMode
  3914.     move.l    d1,opLit    ; Compile a literal fetch of FltFlg value to D2
  3915.     moveq    #2,d0
  3916.     bsr    FetchToD
  3917. ;    move.l    numLoc,opLit
  3918. ;    moveq    #1,d0    ; And number of locals to D1
  3919. ;    bsr    FetchToD
  3920.     get.l    ptrLFdisp,-(a6)    ;    JSR    LFdisp-base(a3)
  3921.     bsr    CompJSRnoPush
  3922.     bra.s    .ceFPrst
  3923.  
  3924. .ceFPU            ; Using FPU.  We only have to dispose if
  3925.             ;  some parms/locals didn't fit in the FP regs.
  3926.     moveq    #5,d0
  3927.     moveq    #0,d2
  3928. .ceFloop
  3929.     lsr.l    #1,d1    ; Look at bit for next p/l - floating?
  3930.     bcs.s    .ceF
  3931.     addq    #1,d2    ; No - count non-floating operands
  3932.     bra.s    .ceFloop    ;  and loop
  3933.  
  3934. .ceF    beq.s    .ceFPrst    ; Yes, but it was the last one, so we're done
  3935.     dbra    d0,.ceFloop    ; Not the last one.  Loop if any FP regs left.
  3936.     lsl.l    d2,d1    ; None.  Shift FltFlg back - now it only flags
  3937.     bra.s    .ceDsp    ;  Dn/XL floating operands, with strictly
  3938.             ;  one bit per D reg or XL locn.  We dispose
  3939.             ;  them as for non-FPU code.
  3940.  
  3941. ; Now we must restore any FP regs used.
  3942.  
  3943. .ceFPrst
  3944.     get.l    useFPUq,d0
  3945.     beq.s    .ce0
  3946.     get.l    numF,d0
  3947.     beq.s    .ce0
  3948.     move.w    #$3F,d1    ; fmovem mask for FP2-FP7
  3949.     moveq    #6,d2
  3950.     sub.w    d0,d2    ; Work out how many we really need to restore
  3951.     ble.s    .ceFmany    ; If all
  3952.     move.w    d1,d0    ; Not all - shift and mask the mask
  3953.     lsl.w    d2,d0
  3954.     and.w    d0,d1
  3955.     bsr    LowBit
  3956.     blt.s    .ceFone
  3957.  
  3958. .ceFmany
  3959.     move.l    #$F21FD000,d0    ;    fmovem    (a7)+,<regs>
  3960.     or.w    d1,d0
  3961.     push.l    d0
  3962.     jsr    comma
  3963.     bra.s    .ce0
  3964.  
  3965. .ceFone    push.l    #$F21F4900,d0    ;    fmovem    (a7)+,FP2
  3966.     jsr    comma
  3967.  
  3968. ; Now we'll restore the XL locations and D regs which have been saved on the
  3969. ; return stack in the save phase.
  3970.  
  3971. .ce0    lea    XLOD,a0
  3972.     move.l    XLdispl,opDispl
  3973.     move.w    #$F0,rstRegMask-hbase(a4) ; Initial MOVEM mask for restoring D regs
  3974.     move.l    numPLadj,d6    ; D6 = numPL, adjusted
  3975.     get.l    numP,d5    ; D5 = numP
  3976.     moveq    #0,d4    ; D4 will hold no of ExtraLocals (XL) locations
  3977.     moveq    #4,d2
  3978.     sub.l    d6,d2    ; D2 = number of unused reg slots
  3979.     bpl.s    .ceRegs    ; Positive - we didn't use the XL area
  3980.             ; We did use the XL area.
  3981.     sub.l    d2,d4    ; D4 = number of XL locations
  3982.     cmp.b    #3,d4    ; Greater than 3?
  3983.     ble.s    .ceXLloop
  3984.     move.w    #$F8,rstRegMask-hbase(a4) ; Yes - include D3 in mask for restoring regs
  3985.  
  3986. .ceXLloop            ; Loop to pop rtn stk to XL locations
  3987.     move.w    #$3FF,d1    ;  10 at a time.
  3988.     sub.w    #10,d4
  3989.     bgt.s    .cex1
  3990.             ; Last time round.
  3991.     cmp.w    #-9,d4    ; Only one left?
  3992.     beq.s    .ceMv1    ; Yes
  3993.     move.w    d4,d2    ; No
  3994.     neg.w    d2
  3995.     lsr.w    d2,d1    ; Adjust MOVEM mask
  3996.     bra.s    .cex1
  3997.  
  3998. .ceMv1    move.w    XLeaBits,d0    ; Only one to be moved.  Use MOVE instead
  3999.     move.l    d0,d1    ;  of MOVEM
  4000.     and    #7,d0
  4001.     lsl    #6,d0
  4002.     and    #$38,d1
  4003.     or    d1,d0
  4004.     lsl    #3,d0
  4005.     or.w    #$201F,d0
  4006.     push.l    d0
  4007.     jsr    wcomma
  4008.     bsr    CompExt
  4009.     bra.s    .ceAllRegs
  4010.  
  4011. .cex1            ; Not last time.
  4012.     moveq    #$1F,d0    ; ea bits for (a7)+
  4013.     moveq    #1,d2    ; Not predecrement, mem to reg
  4014.     bsr    compMOVEM    ;    movem.l    (a7)+,d0-d7/a0/a1
  4015.     move.w    XLeaBits,d0
  4016.     moveq    #0,d2    ; Not predecrement, reg to mem
  4017.     bsr    CompMOVEM    ;    movem.l    d0-d7/a0/a1,<XL+n>
  4018.     add.l    #40,opDispl    ; Increment XL addr by 40 for next time round
  4019.     tst.w    d4
  4020.     bgt.s    .ceXLloop
  4021.  
  4022. .ceAllRegs        ; Finished restoring XL area.
  4023.     moveq    #0,d2
  4024.  
  4025. .ceRegs    move.w    rstRegMask,d1    ; Now we restore the D regs.
  4026.     move.w    d1,d0
  4027.     lsr.w    d2,d0    ; D2 = number of unused regs.
  4028.     and.w    d0,d1
  4029.     moveq    #$1F,d0    ; ea bits for (a7)+
  4030.     moveq    #1,d2    ; Not predecrement, mem to reg
  4031.     bsr    compMOVEM    ;    movem.l    (a7)+,<regs>
  4032.  
  4033. .ce1    get.l    numLast,d0    ; If any CallLast calls to be made, we
  4034.     bne.s    .ceOut    ;  get out - caller will handle
  4035.  
  4036. hDefnEnd        ; Entry point called by ;m to compile the actual end
  4037.             ;  of a definition if there were any CallLast calls,
  4038.             ;  since these had to come first.
  4039.             
  4040.     get.b    Methodq,D0    ; Method?
  4041.     beq.s    .ce3    ; No
  4042.     compop    xRpopA2    ; Yes - compile MOVE.L (A7)+,A2 to restore A2
  4043.  
  4044. .ce3    get.b    colaFlg,d0    ; :A definition?
  4045.     beq.s    .ce4    ; No
  4046.     get.l    MBcomp,d0    ; Are we actually compiling a module?
  4047.     addq.l    #1,d0
  4048.     beq.s    .ce4    ; No
  4049.     compop    xRpopA5    ; Yes - compile   move.l  (a7)+,a5
  4050. ;    move.l    colaFlg,a0
  4051. ;    sf    (a0)
  4052.  
  4053. .ce4    lea    OD,a0
  4054.     cmp.b    #otJSR,(a0)
  4055.     bne.s    compRTS
  4056.     bsr    JSRtoJMP
  4057.     beq.s    compRTS
  4058. .ceOut    rts
  4059.  
  4060. compRTS
  4061.     compop    xRTS
  4062.     rts
  4063.  
  4064.  
  4065. ; hColA handles the entry sequence for :A words.  These need to push A5
  4066. ; on to the return stack at the start, then set A5 to where MBcomp points
  4067. ; at compile time.  :A words are needed for exported classes, since an object
  4068. ; can exist in one module whose class is implemented in another module.  If one
  4069. ; of the methods executes an action handler or whatever that is a part of the
  4070. ; object, and which lives in the same module as the object (which is quite normal),
  4071. ; A5 will be wrong when the action handler executes.  :A and ;A solve
  4072. ; this problem, by temporarily restoring A5 to its right value for the module
  4073. ; containing the :A word.
  4074.  
  4075. hColA    loc
  4076.     move.l    colaFlg,a0
  4077.     st    (a0)
  4078.     get.l    MBcomp,d0    ; Are we actually compiling a module?
  4079.     move.l    d0,d1
  4080.     addq.l    #1,d1
  4081.     beq.s    .out    ; If not, skip the rest
  4082.     compop    xRpshA5    ; Compile   move.l  a5,-(a7)
  4083.     get.l    inhibitMBq,-(a6)    ; Save inhibit modbase flag
  4084.     moveq    #-1,d1    ;  and set it true - in setting A5 to the
  4085.     move.l    d1,(a1)    ;  MBcomp value, we mustn't use A5 in the
  4086.     push.l    d0    ;  addressing step, since it probably won't
  4087.     bsr    saveOD    ;  be valid (this is why we're using :A after
  4088.     bsr    SetAddr    ;  all).
  4089.     clr.b    opind
  4090.     move.b    #AnReg+5,opToFrom
  4091.     bsr    CompFetch
  4092.     put.l    (a6)+,inhibitMBq
  4093.  
  4094. .out    rts
  4095.  
  4096. ;        ====================================
  4097.  
  4098. ;         NAMED PARAMETERS AND LOCAL VARIABLES
  4099.  
  4100. ;        ====================================
  4101.  
  4102.  
  4103. GetRegNum        ; Utility routine to get the Dn reg number for the current
  4104.     loc    ; parm or local.  If really Dn, returns reg# in D0, and
  4105.         ; leaves CC NE.  If really in the XL area, returns
  4106.         ; the XL item number in D0, and leaves CC EQ.
  4107.         ; Uses D1-D4.
  4108.  
  4109.     get.l    locno,d0
  4110.     get.l    useFPUq,d1
  4111.     beq.s    .grn1
  4112.     cmp.l    numLoc,d0
  4113.     blt.s    .grnLoc
  4114.     sub.l    RegNumAdjustment,d0
  4115. .grn1    subq.l    #4,d0    ; Is it in Dn or XL area?
  4116.     bge.s    .grnXL
  4117.     addq.l    #8,d0    ; Dn.  n to d0.  Can't be 0, so
  4118.     rts        ;  sets CC NE as well.
  4119.  
  4120. .grnXL    move    #4,CCR
  4121.     rts
  4122.  
  4123. .grnLoc
  4124.     get.l    FltFlg,d4
  4125.     move.l    d0,d1
  4126.     moveq    #6,d2
  4127.     bra.s    .grnLpTst
  4128. .grnLoop
  4129.     lsr.l    #1,d4
  4130.     bcc.s    .grnLpTst
  4131.     subq.l    #1,d0
  4132.     subq    #1,d2
  4133.     beq.s    .grn1
  4134. .grnLpTst
  4135.     dbra    d1,.grnLoop
  4136.     bra.s    .grn1
  4137.  
  4138.  
  4139.  
  4140. GetFPnum        ; Utility routine to get the reg number for the current
  4141.         ; FP parm/local.  If FPn, we return reg# in D0, and
  4142.         ; leave CC NE.  If Dn, (i.e. an FP heap addris in Dn), we
  4143.         ; return the D reg no in D0 and leave the CC EQ.
  4144.         ; If in the XL area, we leave D0 = -1, return
  4145.         ; the XL item number in D1, and leave CC EQ.
  4146.         ; Uses D1-D4.
  4147.  
  4148.     get.l    locno,d0
  4149.     get.l    useFPUq,d1
  4150.     beq    .gfNotFPn    ; If we're not compiling FPU code, operand
  4151.             ;  isn't in FPn.
  4152.     move.w    d0,d1    ; D1 will be loop counter
  4153.     get.l    FltFlg,d4
  4154.     beq.s    .gfErr    ; OK OK, so I'm a suspicious character.
  4155.     moveq    #0,d0    ; D0 will count "D regs"
  4156.     moveq    #6,d2    ; D2 will count down # of free FP regs
  4157.     move.l    NumLoc,d3    ; D3 will count down # of locals
  4158.     bra.s    .gfTst
  4159.  
  4160. .gfLoop    lsr.l    #1,d4
  4161.     bcs.s    .gfFP
  4162.     subq    #1,d3
  4163.  
  4164. .gfDinc    addq    #1,d0    ; Increment D reg count
  4165.     bra.s    .gfTst
  4166.  
  4167. .gfFP    subq    #1,d2    ; FP operand.  Any FP regs left?
  4168.     blt.s    .gfDinc    ; No.  Inc D reg count
  4169.     subq    #1,d3    ; Yes.  Still doing locals?
  4170.     blt.s    .gfDinc    ; No.  Inc D reg count
  4171.  
  4172. .gfTst    dbra    d1,.gfLoop
  4173.  
  4174.     tst.w    d2
  4175.     ble.s    .gfNotFPn
  4176.     moveq    #8,d0
  4177.     sub.w    d2,d0    ; Get FP reg no to D0.  Must set CC NE.
  4178.     rts
  4179.  
  4180. .gfNotFPn            ; Operand isn't in FPn.
  4181.     subq.l    #4,d0    ; Is it in Dn or XL area?
  4182.     bge.s    .gfXL
  4183.     addq.l    #8,d0    ; Dn.  n to d0.
  4184.     move    #4,CCR    ; Set CC EQ as well.
  4185.     rts
  4186.  
  4187. .gfXL    move.l    d0,d1
  4188.     moveq    #-1,d0
  4189.     move    #4,CCR
  4190.     rts
  4191.  
  4192. .gfErr    dc.w    $FFE7
  4193.  
  4194.  
  4195.     hndlr    loc_h,0        ; loc_h
  4196.  
  4197.     addq    #4,a6    ; Don't need address of dummy LOCPARM
  4198.     bsr    GetRegNum
  4199.     beq.s    .locXL
  4200.     move.b    #mdDn,d4
  4201.     moveq    #0,d5
  4202.  
  4203. ; Floating locals come in here.
  4204.  
  4205. locH
  4206.     bsr    SaveOD
  4207.     move.b    d0,opReg    ; Set up ODnew
  4208.     move.b    d4,opMode
  4209.     move.b    d5,opFlags
  4210. loc2    move.b    #1,opind    ; Contents of the reg is the operand
  4211. loc3    tst.w    opcode+2-hbase(a4)    ; From now on it's the same as a Value,
  4212.     beq    ftchVal1    ; but we don't call SetAddr.
  4213.     bra    stVal1
  4214.  
  4215. .locXL    asl.l    #2,d0
  4216.     add.l    ExtraLocals,d0
  4217.     push.l    d0
  4218.     bra    valH
  4219.  
  4220. ;        =======================
  4221.  
  4222. ; Handler for floating named parms or locals.
  4223.  
  4224. flODaddr    long
  4225.  
  4226.     hndlr    Floc_h,0                ; Floc_h
  4227.  
  4228.     addq    #4,a6    ; Don't need address of dummy FLOCPARM
  4229.     sf    FatStq-hbase(a4)
  4230.     bsr    GetFPnum
  4231.     beq.s    .flNotFPn
  4232.     move.b    #mdFPn,d4
  4233.     move.b    #fbFP,d5
  4234.     bra.s    locH
  4235.  
  4236. .flNotFPn
  4237.     st    Flocq-hbase(a4)    ; Not in FPn.  Not much point in optimizing.
  4238.     tst.w    d0    ; Where is the operand?
  4239.     bmi    .flXL
  4240.     st    d7    ; Dn.  Set flag.  D reg no is in D0.
  4241.     move.l    d0,d4    ; Also save in D4
  4242.     tst.l    opcode-hbase(a4)    ; Fetching or storing?
  4243.     bne.s    .flst
  4244.             ; Fetching.
  4245.     or.w    xMvD0A1,d0    ; Convert to  MOVE.L Dn,A1
  4246.     push.l    d0
  4247.     jsr    wcomma    ; Compile that.
  4248.  
  4249. .fl2    get.l    ptrLfloat,-(a6)    ;    JSR    Lfloat-base(a3)
  4250.     bsr    CompJSRnoPush
  4251.     tst.b    d7
  4252.     beq    releaseOD
  4253.     rts
  4254.             ; Storing.
  4255. .flst    or.w    xMvD0D2,d0    ;    MOVE.L Dn,D2
  4256.     push.l    d0
  4257.     jsr    wcomma    ; Compile that
  4258.  
  4259. .flst1    get.l    ptrToLfloat,-(a6)
  4260. flst2    move.l    opcode,d1    ; Storing or operating to the flt loc?
  4261.     cmp.b    #otStore,d1
  4262.     blt.s    .fop
  4263.     moveq    #-1,d1    ; Storing.  We use -1 as opcode for ToLfloat
  4264.     bra.s    .fmvq
  4265.  
  4266. .fop    lsl.w    #1,d1    ; Other operation (add or whatever).
  4267.     lea    xSANE-((otFPops+1)*2),a0
  4268.     move.w    0(a0,d1.w),d1    ; Get SANE opcode
  4269.  
  4270. .fmvq    moveq    #1,d0    ; Compile:
  4271.     bsr    CompMoveq    ;     MOVEQ    #<opcode>,D1
  4272.     bsr    CompJSRnoPush    ;    JSR    <wherever>
  4273.     tst.b    Flocq-hbase(a4)    ; Local/parm or Fvalue?
  4274.     beq.s    .flOut    ; Out if Fvalue
  4275.  
  4276.     tst.b    d7    ; Local/parm.  In Dn or XL area?
  4277.     beq.s    .flstXL
  4278.     ror.w    #7,d4    ; Dn - we compile:
  4279.     or.w    xMvD2D0,d4
  4280.     push.l    d4
  4281.     jmp    wcomma    ;    MOVE.L    D2,Dn
  4282.  
  4283. .flstXL    move.l    flODaddr,a0    ; XL area.  Compile a store from D2 to the
  4284.     move.b    #2,opToFrom    ; XL location.
  4285.     move.b    #otStore,(a0)
  4286.     bsr    CompStore
  4287.     bra    releaseOD    ; We will have been using a temp OD, so we
  4288.             ;  release it
  4289.  
  4290. .flOut    rts        ; Fvalue - we're done
  4291.  
  4292. .flXL    sf    d7    ; Here we set up for an op on a floating
  4293.     asl.l    #2,d1    ; parm/local in the XL area.  Item# is in D1.
  4294.     add.l    ExtraLocals,d1    ; XL addr to D1
  4295.     push.l    d1
  4296.     bsr    newClrOD    ; We need a temp OD for this, as ODnew
  4297.             ;  gets used
  4298.     move.l    a0,flODaddr-hbase(a4)    ; Save temp OD addr
  4299.     bsr    SetAddr
  4300.     tst.l    opcode-hbase(a4)    ; Fetching or storing?
  4301.     bne.s    .flXLst
  4302.     moveq    #1,d0    ; Fetching.
  4303.     bsr    FetchToA    ; Compile a fetch of the XL locn to A1
  4304.     bra    .fl2
  4305.  
  4306. .flXLst    moveq    #2,d0    ; Storing.
  4307.     bsr    FetchToD    ; Compile fetch of XL locn to D2
  4308.     bra    .flst1    ; Now handle as for operand in Dn
  4309.  
  4310.  
  4311. ;        ==============================
  4312.  
  4313. ;                METHOD SUPPORT
  4314.  
  4315. ;        ==============================
  4316.  
  4317.     loc
  4318.  
  4319. hGenAddr
  4320.  
  4321. ; ( base-reg displ ind# -- )  Called when we are compiling an in-line
  4322. ;    method, and generating the object address.  The "base-reg" may
  4323. ;    be negative, in which case the "displ" is an absolute address.
  4324.  
  4325.     loc
  4326.     bsr    saveOD
  4327.     move.b    #mdBD,opMode
  4328.     pop.l    d0
  4329.     move.b    D0,opind
  4330.     pop.l    d0
  4331.     pop.l    d1
  4332.     bpl.s    .bd
  4333.     move.l    d0,opAddr
  4334.     bsr.s    getBase    ; If necessary, convert to base-displ
  4335. .bd    move.l    d0,opDispl
  4336.     bset    #6,d1
  4337.     move.b    d1,opBreg
  4338.     bra    FtchVal1
  4339.  
  4340.  
  4341. hLoadBA
  4342.  
  4343. ; ( base-reg displ ind# -- )  Loads the base address of an object to A0.
  4344. ;    This is done for an ivar bind, in the case where we can't generate
  4345. ;    the ivar's address directly at compile time.  This happens when the
  4346. ;    obj addr is in an object pointer.
  4347.  
  4348.     BSR    saveOD
  4349.     MOVE.B    #mdBD,opMode
  4350.     POP.L    D0
  4351.     MOVE.B    D0,opind
  4352.     POP.L    D0
  4353.     MOVE.L    D0,opDispl
  4354.     POP.L    D0
  4355.     bset    #6,d0
  4356.     MOVE.B    D0,opBreg
  4357.     MOVEQ    #0,D0
  4358.     BRA    FetchToA
  4359.  
  4360. Tempind    long
  4361. TempLocDispl    long
  4362. ixShift    word
  4363. ClFlags    word
  4364. iwPwr2    byte
  4365.     align
  4366.  
  4367. hGenxAddr
  4368.  
  4369. ; ( xwid xoffs base-reg displ local-displ ind flags -- )
  4370.  
  4371. ; Called by IX when we are compiling an in-line method, and generating
  4372. ; the address of an indexed element of the current object.
  4373. ; The base-reg, displ and ind refers to the obj addr.  xoffs is the offset
  4374. ; to the indexed area, if we know it.  This will happen if the obj
  4375. ; is a straight object or an ivar (ivars are generic to a class, but
  4376. ; each one has a fixed xoffs).  In these cases we can absorb the xoffs
  4377. ; at compile time.  If, however, the "obj" is self or super, then we won't
  4378. ; know the xoffs at compile time, since at different points in the class
  4379. ; hierarchy the xoffs is different.  It is always located at run time
  4380. ; in the word preceding the class pointer.  In this case we will pass in
  4381. ; a negative "xoffs".
  4382. ; As for hGenaddr, the "base-reg" may be negative, which means that the
  4383. ; "displ" is actually an absolute addr.
  4384.  
  4385.     loc
  4386.     bsr    saveOD
  4387.     pop.l    D0
  4388.     move.w    D0,ClFlags-hbase(A4)    ; Save class flags in ClFlags
  4389.     pop.l    tempind-hbase(A4)    ; Save ind in tempind
  4390.     pop.l    tempLocDispl-hbase(A4) ; And local displ in tempLocDispl
  4391.     pop.l    d0    ; Displ to D0
  4392.     pop.l    d1    ; Base reg to D1
  4393.     bpl.s    .bd
  4394.     bsr    getBase    ; If necessary, convert to base-displ
  4395. .bd    move.l    d0,d7    ; D7 = displ
  4396.     move.l    d1,d6    ; D6 = base reg
  4397.     pop.l    d5    ; D5 = xoffs
  4398.     pop.l    d4    ; D4 = xwid
  4399.  
  4400.     MOVEQ    #0,D0
  4401.     BSR    GetToReg    ; Make sure the index is in Dn
  4402.     PUSH.L    D0    ; - leaves actual reg no in D0 - save it
  4403.  
  4404.     MOVE.L    D4,D2
  4405.     MOVEQ    #0,D3    ; Set up to find if only one bit is set.
  4406. .loop    ROR.L    #1,D2    ; Rotate width right - low bit goes to carry
  4407.     BCS.S    .gx0    ;  as well as to high word (which we'll ignore)
  4408.     ADDQ    #1,D3
  4409.     BRA.S    .loop
  4410. .gx0    TST.W    D2    ; Any other bits of the width set?  Note this
  4411.     SEQ    iwPwr2-hbase(A4)    ; is a word test, ignoring the high garbage
  4412.     BNE.S    .chkD0    ; No
  4413.     MOVE.W    D3,ixShift-hbase(A4) ; Yes - i.e. a power of 2.
  4414.             ; Is it 2**0 = 1 ?
  4415.     BEQ.S    .gx1    ; Yes - we can leave index where it is
  4416.  
  4417. .chkD0    CMP.B    #2,D0    ; No - index must go to a temp Dn
  4418.     BLE.S    .gx1
  4419.     OR.W    #$2000,D0
  4420.     PUSH.L    D0
  4421.     JSR    wcomma    ; Emit MOVE to get it to D0 if necessary
  4422.     CLR.L    (A6)    ; Reset our index reg # to D0
  4423.  
  4424. .gx1    CLR.W    OD-hbase(A4)    ; Can't opt back
  4425.     BSR    initODs    ; Now get a new desc ready to address the obj
  4426.     MOVE.B    #AnReg,opToFrom
  4427.     MOVE.B    #otFetch,(A0)
  4428.     MOVE.B    #mdBD,opMode
  4429.     MOVE.L    D7,opDispl
  4430.     bset    #6,d6
  4431.     MOVE.B    D6,opBreg
  4432.     MOVE.B    tempind+3,opind    ; Is this the actual obj addr?
  4433.     BEQ.S    .gx2    ; Yes
  4434.     BSR    CompFetch    ; No: compile a load of the addr to A0
  4435.     move.b    #AnReg,opBreg    ; A0 is now the base reg
  4436.     clr.l    opDispl    ;  and the displ is zero
  4437.     
  4438. .gx2    move.l    tempLocDispl,d0
  4439.     bsr    offsetAddr    ; Offset the obj addr by the local offset
  4440.     tst.w    d5    ; Do we have a real xoffs?
  4441.     bmi.s    .gxNox
  4442.  
  4443.     move.w    d5,d0    ; Yes - add the xoffs to the obj addr
  4444.     ext.l    d0    ;  to get the addr of the indexed area
  4445.     bsr    offsetAddr
  4446.     bra.s    .doChk
  4447.  
  4448. .gxNox    MOVEQ    #0,D0    ; No.  First compile a LEA to A0
  4449.     BSR    compLEA
  4450.     PUSH.L    xgxself    ; then the sequence to get the index base
  4451.     JSR    comma    ;  to A0
  4452.     PUSH.L    xgxself+4
  4453.     JSR    comma
  4454.     move.b    #AnReg,opBreg
  4455.     CLR.L    opDispl
  4456.  
  4457. .doChk    btst.b    #0,ClFlags+1    ; Is this array large ( >64K elements )?
  4458.     bne.s    .chkDone    ; Yes: skip CHK
  4459.     moveq    #-2,d0
  4460.     bsr    OffsetAddr    ; Range word is at -2 rel to index base
  4461.     moveq    #0,d0
  4462.     bsr    LoadBase    ; LoadBase for CHK or LEA
  4463.     move.l    opDispl,d0
  4464.     addq.l    #2,d0    ; Will displ of index base fit in 8 bits?
  4465.     bsr    ByteChk
  4466.     beq.s    .dc3    ; Yes - no need to LEA
  4467.     moveq    #0,d0    ; No
  4468.     bsr    CompLEA    ;    LEA  <range word>,A0
  4469.     move.b    #mdBD,opMode    ; Now mode = BD
  4470.     move.b    #AnReg,opBreg    ; Breg = A0
  4471.     clr.l    opDispl    ; Displ = 0
  4472.     
  4473. .dc3    MOVE.L    (A6),D0    ; Index D reg no to D0
  4474.     ROR.W    #7,D0
  4475.     OR.W    #$4180,D0
  4476.     BSR    CompMop2    ; Compile CHK
  4477.     moveq    #2,d0
  4478.     bsr    OffsetAddr    ; Restore index base addr
  4479.     resetDP        ; We can't optimize back from here
  4480.  
  4481. .chkDone
  4482.     MOVE.L    (A6),D0    ; Restore D0 = index D reg no
  4483.     MOVE.B    #mdX,opMode
  4484.     MOVE.B    D0,opXreg
  4485.     CLR.B    opind
  4486.     TST.B    iwPwr2-hbase(A4)    ; Index width = power of 2?
  4487.     BEQ.S    .doMul    ; No
  4488.     MOVE.W    ixShift,D0    ; Yes
  4489.     BNE.S    .shft
  4490.     BSR    CompAnyNew    ; ..and if 2**0, no shift necessary
  4491.     ADDQ    #4,A6
  4492.     RTS
  4493.  
  4494. .shft    ROR.W    #7,D0
  4495.     OR.L    (A6)+,D0
  4496.     OR.W    #$E188,D0    ; LSL.L  #n,Dn.  Actually it will always
  4497.     PUSH.L    D0    ;  be D0 unless we change something later.
  4498.     JSR    wcomma
  4499. .mkdp    resetDP        ; If we shifted or MULU'd, we can't opt back
  4500.     BRA    CompAnyNew
  4501.  
  4502. .doMul    btst.b    #0,ClFlags+1    ; Is this array large ( >64K elements )?
  4503.     bne.s    .domulx
  4504.     or.l    #$C0FC0000,d4    ; mulu  #n,dn
  4505.     pop.l    d0
  4506.     ror.l    #7,d0
  4507.     or.l    d0,d4
  4508.     push.l    d4
  4509. .comma    jsr    comma
  4510.     bra.s    .mkdp
  4511.  
  4512. .domulx    move.l    d4,d1    ; We have a large array.
  4513.     moveq    #1,d0    ; Compile MOVEQ of the elt width to D1.
  4514.     bsr    CompMOVEQ
  4515.     addq    #4,a6
  4516.     get.L    xMulX,-(a6)    ; And compile call to MulX to multiply it
  4517.             ; by the (long) index in D0.  NOTE: this
  4518.             ; ASSUMES that the index is in D0 (it is,
  4519.             ; unless we change something later) and that
  4520.             ; the width is < 256.  Also the MulX code
  4521.             ; ASSUMES that the top half of D1 will be zero
  4522.             ; if we're running on a 68020 or better
  4523.             ; - it uses a MULU.L instruction.
  4524.     bra.s    .comma
  4525.  
  4526.  
  4527. ; hEB ( cfa -- )
  4528. ;  Compiles an early bind.  Called from EB.  Code will just have been compiled
  4529. ;  to get the object's address to the stack at run time.  Our optimization
  4530. ;  improves this if possible.
  4531.  
  4532. heb    bsr    saveOD    ; We compile:
  4533.     moveq    #AnReg,d0    ;  (get ^obj to A0, by LEA or whatever)
  4534.     bsr    GetToReg
  4535. heb1    get.l    HeldMod,d0    ; Are we invoking a module?
  4536.     bne.s    .hebMod    ; Yes
  4537.             ; No. Just compile
  4538.     bra    CompJSR    ;    JSR    cfa (the method)
  4539.  
  4540. .hebMod    move.l    d0,(a6)    ; Replace "cfa" (garbage) with active
  4541.     lea    tmpOD,a0    ;  module addr
  4542.     bsr    setAddr
  4543.     moveq    #0,d0
  4544.     bsr    LoadBase
  4545.     moveq    #1,d0
  4546.     bsr    CompLEA    ;    lea    <^mod>,a1
  4547.     push.l    EBmod
  4548.     bsr    CompJSR    ;    jsr    EBmod
  4549.     get.l    MethIndex,-(a6)
  4550.     jmp    wcomma
  4551.  
  4552. hStkObj
  4553.  
  4554. ; ( -- base displ ind )  Sets up for an early bind to an object whose
  4555. ;    (data) addr is on the stack at run time.  We also handle object
  4556. ;    pointers this way, by first compiling a fetch of the objPtr
  4557. ;    to the stack, and relying on our optimization to improve the code.
  4558. ;    Rather than leaving the ^obj on the stack, we return the addressing
  4559. ;    info back to the CLASS code.  This is because we may be binding to an
  4560. ;    inline method which uses OBJ anywhere - more than once, even.
  4561.  
  4562.     loc
  4563.     BSR    saveOD
  4564.     LEA    ODsav,A0
  4565.     CMP.B    #otFetch,OD-hbase(A4)
  4566.     BNE.S    .getToA0
  4567.     CMP.B    #mdBD,opMode
  4568.     BNE.S    .getToA0
  4569.     MOVEQ    #0,D0
  4570.     MOVE.B    opBreg,D0
  4571.     and.b    #7,d0
  4572.     PUSH.L    D0
  4573.     MOVE.L    opDispl,D0
  4574.     PUSH.L    D0
  4575.     MOVEQ    #0,D0
  4576.     MOVE.B    opind,D0
  4577.     PUSH.L    D0
  4578.     backDP
  4579.     BSR    popOD
  4580.     RTS
  4581.  
  4582. .getToA0
  4583.     MOVEQ    #AnReg,D0
  4584.     BSR    GetToReg
  4585.     CLR.L    -(A6)
  4586.     CLR.L    -(A6)
  4587.     CLR.L    -(A6)
  4588.     RTS
  4589.  
  4590.  
  4591. ;        =========================
  4592.  
  4593. ;                DO LOOPS
  4594.  
  4595. ;        =========================
  4596.  
  4597.     loc
  4598.  
  4599. ; CompPlLoop handles +LOOP.  We optimize the case  <fetch> +LOOP.
  4600.  
  4601.  
  4602. PlLoop_M    macrox    &1
  4603.     POP.L    D0
  4604.     BPL.S    .up
  4605.     ADD.L    D0,D3
  4606.     MOVE.L    (A7),D0
  4607.     SUBQ.L    #1,D0
  4608.     CMP.L    D3,D0
  4609.     BRA.S    .tst
  4610.  
  4611. .up    ADD.L    D0,D3
  4612.     CMP.L    (A7),D3
  4613. .tst    BLT    &1
  4614.     ADDQ.L    #8,A7
  4615.     MOVE.L    (A7)+,D3
  4616.     endm
  4617.  
  4618. PlLpD_M    macrox    &1
  4619.     BPL.S    .up
  4620.     ADD.L    D0,D3
  4621.     MOVE.L    (A7),D0
  4622.     SUBQ.L    #1,D0
  4623.     CMP.L    D3,D0
  4624.     BRA.S    .tst
  4625.  
  4626. .up    ADD.L    D0,D3
  4627.     CMP.L    (A7),D3
  4628. .tst    BLT    &1
  4629.     ADDQ.L    #8,A7
  4630.     MOVE.L    (A7)+,D3
  4631.     endm
  4632.  
  4633. plLpUp_m    macrox    &1
  4634.     CMP.L    (A7),D3
  4635.     BLT    &1
  4636.     ADDQ.L    #8,A7
  4637.     MOVE.L    (A7)+,D3
  4638.     endm
  4639.  
  4640. PlLpDn_m    macrox    &1
  4641.     CMP.L    (A7),D3
  4642.     BGE    &1
  4643.     ADDQ.L    #8,A7
  4644.     MOVE.L    (A7)+,D3
  4645.     endm
  4646.  
  4647.  
  4648. pplloop_m    macrox
  4649.     plLoop_m    dummylab
  4650.     endm
  4651.  
  4652. ppLpD_m    macrox
  4653.     PlLpD_m    dummylab
  4654.     endm
  4655.  
  4656. ppLpUp_m    macrox
  4657.     plLpup_m    dummylab
  4658.     endm
  4659.  
  4660. ppLpDn_m    macrox
  4661.     plLpDn_m    dummylab
  4662.     endm
  4663.  
  4664.     loc
  4665.     nohead    pplloop,inline
  4666.     loc
  4667.     nohead    ppLpD,inline
  4668.     loc
  4669.     nohead    ppLpUp,inline
  4670.     loc
  4671.     nohead    ppLpDn,inline
  4672.     loc
  4673.     word
  4674.  
  4675. dummyLab
  4676.     dc.w    $FFE2
  4677.  
  4678.  
  4679. CompPlLoop
  4680.     BSR    SaveOD
  4681.     BSR    ChkOpt
  4682.     BEQ.S    .cplNo
  4683.     CMP.B    #otFetch,D1
  4684.     BEQ.S    .cplF
  4685. .cplNo    compyl    pplloop
  4686.     RTS
  4687.  
  4688. .cplF    lea    ODsav,A0
  4689.     backDP
  4690.     cmp.b    #mdLit,opMode
  4691.     beq.s    .cplLit
  4692.     st    ForceToR-hbase(a4)
  4693.     moveq    #0,D0
  4694.     bsr    FetchToD
  4695.     compyl    ppLpD
  4696.     rts
  4697.  
  4698. .cplLit    move.b    #otAdd,operation-hbase(A4)
  4699.     LEA    ODnew,A1
  4700.     MOVE.B    #3,opReg(A1)
  4701.     MOVE.B    #mdDn,opMode(A1)
  4702.     MOVE.B    #1,opInd(A1)    ; Contents of the reg is the operand
  4703.     BSR    OP2
  4704.     LEA    ODsav,A0
  4705.     TST.L    opLit
  4706.     BLT.S    .cplDn
  4707.     compyl    ppLpUp
  4708.     RTS
  4709. .cplDn    compyl    ppLpDn
  4710.     RTS
  4711.  
  4712.  
  4713. ;        =============================
  4714.  
  4715. ; COMPIMP  ( ^mod -- )  handles the compilation of the runtime code
  4716. ;  for imported words, as defined in the construct
  4717. ;  FROM <modName> IMPORT{ <name0> <name1> ... }
  4718. ;  ^mod is the data address of the module object, and n is the number
  4719. ;  of this name in the list, starting at zero.
  4720.  
  4721. Compimp
  4722.     geta    modEntry,-(A6)    ; We compile:
  4723.     bsr    CompJSR    ;    JSR    modEntry
  4724.     clr.l    -(a6)
  4725.     jsr    wcomma    ; Leave space for 2-byte index into the
  4726.             ; module's export table.
  4727.     pop.l    d0
  4728.     get.l    DP,d1
  4729.     sub.l    d1,d0
  4730.     push.l    d0
  4731.     jmp    wcomma        ; module offset (2 bytes)
  4732.  
  4733.  
  4734. ;    ============================================
  4735.  
  4736. ;    HANDLERS FOR INDIVIDUAL TYPES AND OPERATIONS
  4737.  
  4738. ;    ============================================
  4739.  
  4740.     loc
  4741.  
  4742. constAddr    long
  4743.  
  4744.     hndlr    const_h,0            ; const_h
  4745.     MOVE.L    (A6),A0
  4746.     MOVE.L    A0,constAddr-hbase(A4)
  4747.     MOVE.L    (A0),(A6)    ; Fetch const value
  4748.  
  4749. litCon    BSR    SaveOD
  4750.     MOVE.W    #tsFetch+Lcode,(A0)    ; Type = fetch, length = L
  4751.     MOVE.B    #stkPush,opToFrom    ; Mark dest as stk
  4752.     POP.L    D0    ; Value
  4753.     MOVE.L    D0,opLit    ; Store in opLit field in descriptor
  4754.     BSR    ByteChk
  4755.     beq.s    .lit
  4756. ;    BNE.S    .long
  4757. ;    MOVE.B    #1,opShort    ; Set short lit flag
  4758. ;    BRA.S    .lit
  4759.  
  4760. .long    TST.L    constAddr-hbase(A4)
  4761.     BEQ.S    .lit
  4762.     PUSH.L    constAddr-hbase(A4)    ; Long constant - same as Value.
  4763.     BSR    SetAddr
  4764.     BRA.S    .compF
  4765.  
  4766. .lit    MOVE.B    #mdLit,opMode    ; Literal number.  Set mode = lit
  4767.     clr.b    opind
  4768.  
  4769. .compF    BSR    compFetch
  4770. .mkopt    BSR    PushOD
  4771.     RTS
  4772.  
  4773.  
  4774. Literal
  4775. ; ( n -- )
  4776.     CLR.L    constAddr-hbase(A4)
  4777.     BRA.S    litCon
  4778.  
  4779.  
  4780. LitAddr
  4781. ; ( addr -- )
  4782. litAddr1        ; create_h comes in here
  4783.     bsr    saveOD
  4784.     bsr    SetAddr
  4785.     clr.b    opind
  4786.     bra.s    FtchVal1
  4787.  
  4788. ;        ===========================
  4789.  
  4790.     hndlr    val_h,0            ; val_h
  4791. valH    BSR    SaveOD
  4792.     bsr    SetAddr
  4793.     TST.L    opcode-hbase(A4)
  4794.     BNE.S    StoreVal
  4795. ;    BSR    SetAddr    ; Fetch
  4796. ftchVal1
  4797.     MOVE.W    #tsFetch+Lcode,(A0)    ; Type/subtype = fetch, long
  4798.     MOVE.B    #stkPush,opToFrom    ; Dest = stack
  4799.     bra    fChk
  4800.  
  4801. StoreVal            ; Store
  4802. ;    bsr    setAddr
  4803. stVal1    move.l    opcode,d3
  4804.     lsl.w    #8,d3
  4805.     btst    #flFP,opFlags    ; Is it an FP value?
  4806.     bne.s    .stv2
  4807.  
  4808. .stv1    or.b    #Lcode,D3
  4809. .stv2    move.w    d3,(a0)    ; Set type/subtype (in ODnew)
  4810.     move.b    #stkPop,opToFrom    ; Source = stack
  4811.     bra    stchk
  4812.  
  4813. objPtr_h    equ    val_h
  4814.  
  4815.  
  4816. ;        ===========================
  4817.  
  4818.  
  4819.     hndlr    vect_h,0            ; vect_h
  4820.     tst.l    opcode-hbase(A4)
  4821.     beq    CompJSR    ; Note - at the moment, any
  4822.             ; code other than zero is assumed
  4823.             ; to be a store to the vector.  It really
  4824.             ; doesn't make much sense to add etc.!
  4825.     bsr    saveOD
  4826.     addq.l    #4,(a6)    ; Dest addr - skip the JSR ExVect
  4827.     bsr    SetAddr
  4828.     moveq    #0,D0
  4829.     bsr    loadbase
  4830.     moveq    #0,d0
  4831.     bsr    CompLEA
  4832.  
  4833. .toVect    get.L    xjsrToVect,-(A6)
  4834.     JMP    comma
  4835.  
  4836.  
  4837. ; hDoEx handles the execution of x-array elements.  The preceding code
  4838. ; should have pushed the required element address at run time.
  4839.  
  4840.     loc
  4841. hDoEx    bsr    saveOD
  4842.     bsr    ChkOpt
  4843.     beq.s    .noOpt
  4844.     lea    ODsav,A0
  4845.     backDP
  4846. ;    move.b    #1,opind
  4847.     moveq    #0,d0
  4848.     bsr    FetchToA
  4849. .ex1    get.l    xAtAbs,-(a6)
  4850.     jsr    comma
  4851.     compop    xJsrA0
  4852.     rts
  4853.  
  4854. .noOpt    compop    xPopA0    ; This will only happen if optimization
  4855.     bra.s    .ex1    ;  is disabled.
  4856.  
  4857.  
  4858.  
  4859. ;        ========================
  4860.  
  4861. ; Handler for floating fetch and store.  These ops are intended for optimized
  4862. ; access to floating arrays.
  4863.  
  4864.     hndlr    Fat_h,0            ; Fat_h
  4865.     sf    Flocq-hbase(a4)
  4866.     st    FatStq-hbase(a4)
  4867.     addq    #4,a6
  4868.     bsr    saveOD
  4869.     move.b    #otFetch,(a0)
  4870.     move.b    #stkPush,opToFrom    ; Dest = stack
  4871.     move.b    #mdBD,opMode    ; Mode = base-displacement
  4872.     move.b    #stkPop,opBreg    ; Base reg = stack
  4873.     move.b    #1,opind    ; Memory operand (displ = 0)
  4874.     get.l    UseFPUq,d0    ; Compiling FPU code?
  4875.     beq    FvNoOpt    ; No.  Proceed as for floating values
  4876.  
  4877.     bset    #flFP,opFlags
  4878.     bra    atChkOpt
  4879.     
  4880.  
  4881.     hndlr    Fst_h,0            ; Fst_h
  4882.     sf    Flocq-hbase(a4)
  4883.     st    FatStq-hbase(a4)
  4884.     addq    #4,a6
  4885.     bsr    saveOD
  4886.     move.b    #otStore,(a0)
  4887.     move.w    #otStore,opcode+2-hbase(a4)
  4888.     move.b    #stkPop,opToFrom    ; Source = stack
  4889.     move.b    #mdBD,opMode    ; Mode = base-displacement
  4890.     move.b    #stkPop,opBreg    ; Base reg = stack
  4891.     move.b    #1,opind    ; Memory operand (displ = 0)
  4892.     get.l    UseFPUq,d0    ; Compiling FPU code?
  4893.     beq.s    FvNoOpt    ; No.  Proceed as for floating values
  4894.     move.b    #fbFP,opFlags    ; Yes. Set FP flag in desc 
  4895.     bra    stChkOpt    ; Then proceed as for !
  4896.  
  4897. ; Handler for floating values and constants
  4898.  
  4899.     hndlr    Fval_h,0            ; Fval_h
  4900. fvalcon    sf    Flocq-hbase(a4)
  4901.     sf    FatStq-hbase(a4)
  4902.     bsr    saveOD
  4903.     addq.l    #2,(a6)    ; Offset addr by 2 to skip status word
  4904.     bsr    SetAddr    ; Set up ODnew
  4905.  
  4906. ; Now, if we're compiling FPU code and if we're storing or operating, we go through
  4907. ; the normal store mechanism to allow optimization.
  4908.  
  4909. fval1    get.l    UseFPUq,d0
  4910.     beq.s    FvNoOpt
  4911.     tst.w    opcode+2-hbase(a4)
  4912.     beq.s    FvNoOpt
  4913.     move.b    #fbFP,opFlags
  4914.     bra    StVal1
  4915.  
  4916. FvNoOpt    clr.b    opind
  4917.     move.b    #AnReg+1,opToFrom     ; Compile:
  4918.     bsr    CompFetch    ;    LEA    <addr>,A1  (or whatever)
  4919.     tst.w    opcode+2-hbase(a4)
  4920.     bne.s    .fvst    ; Then, if fetching:
  4921. fvLF    get.l    ptrLfloat,-(a6)    ;    JSR    Lfloat-base(a3)
  4922.     tst.b    FatStq-hbase(a4)    ; If this is F@ or F!, we bypass the status
  4923.     beq.s    .fvJSR    ; word check, since there isn't one!  The
  4924.     addq.l    #8,(a6)    ; check is 8 bytes long, hopefully.
  4925. .fvJSR    bsr    CompJSRnoPush
  4926.     get.l    UseFPUq,d0    ; Compiling FPU code?
  4927.     beq.s    .fvOut    ; No: finished.  Don't push descriptor.
  4928.     lea    ODnew,a0    ; Yes
  4929.     move.b    #otFetch,(a0)
  4930.     move.b    #1,opind
  4931.     move.b    #fbFP,opFlags    ; Set FP bit in flags
  4932.     bra    PushOD
  4933.  
  4934. .fvOut    rts
  4935.             ; If storing, we handle much as
  4936. .fvst    get.l    ptrToFval,-(a6)    ; for flt locals.
  4937.     bra    flst2
  4938.  
  4939. Fcon_h    equ    Fval_h            ; Fcon_h
  4940.  
  4941.     hndlr    FCRcon_h,0            ; FCRcon_h
  4942.     get.l    useFPUq,d0
  4943.     bne.s    .fcrFPU
  4944.     addq.l    #2,(a6)
  4945.     bra    Fvalcon
  4946.  
  4947. .fcrFPU    pop.l    a0
  4948.     move.w    (a0),d0    ; ROM offset to D0
  4949.     sf    Flocq-hbase(a4)
  4950.     sf    FatStq-hbase(a4)
  4951.     bsr    saveOD
  4952.     move.b    #mdFPn,opMode    ; We'll load the ROM constant into FP0
  4953.     move.b    #otFetch,(a0)
  4954.     move.b    #1,opind
  4955.     move.b    #fbFP+fbFCR,opFlags    ; Set FP and FCR bits in flags
  4956.     move.b    d0,opRoffs    ; Set ROM offset byte
  4957.     push.l    a0
  4958.     bsr    newClrOD
  4959.     move.b    #StkPush,opMode
  4960.     move.l    a0,a1
  4961.     move.l    (a6),a0
  4962.     bsr    FPmove
  4963.     bsr    releaseOD
  4964.     pop.l    a0
  4965.     bra    PushOD
  4966.  
  4967.  
  4968. ; hCompFPUL handles the compilation of a literal floating value, if we're
  4969. ; compiling FPU code.  Code has already been compiled to put the addr of the
  4970. ; floating quantity into A1; here we set the operand address as A1 indirect,
  4971. ; then continue as for floating values.
  4972.  
  4973. svFPlit    long    3    ; Save area for current FP literal
  4974. prevFPlit    long    3    ; Saves previous FP literal, so that if we
  4975.             ; recompile while optimizing, we can still
  4976.             ; get the value.
  4977. hCompFPUL
  4978.     movem.l    svFPlit,d0-d2
  4979.     movem.l    d0-d2,prevFPlit-hbase(a4)
  4980.     pop.l    svFPlit-hbase(a4)
  4981.     pop.l    svFPlit+4-hbase(a4)
  4982.     pop.l    svFPlit+8-hbase(a4)
  4983.     sf    Flocq-hbase(a4)
  4984.     sf    FatStq-hbase(a4)
  4985.     bsr    saveOD
  4986.     move.b    #mdBD,opMode
  4987.     move.b    #AnReg+1,opBreg
  4988.     move.b    #otFetch,(a0)
  4989.     move.b    #1,opind
  4990.     move.b    #fbFP+fbLit,opFlags    ; Set FP and Literal bit in flags
  4991.     push.l    a0
  4992.     bsr    newClrOD
  4993.     move.b    #StkPush,opMode
  4994.     move.l    a0,a1
  4995.     move.l    (a6),a0
  4996.     bsr    FPmove
  4997.     bsr    releaseOD
  4998.     pop.l    a0
  4999.     bra    PushOD
  5000.  
  5001.  
  5002.     hndlr    reg_h,2            ; reg_h
  5003.     addq.l    #4,(a6)    ; Skip xinfo flag bytes
  5004.     BSR    SaveOD
  5005.     POP.L    A1
  5006.     MOVE.B    (A1)+,opMode
  5007.     MOVE.B    (A1)+,opReg
  5008.     MOVE.B    #Lcode,opSize
  5009.     CMP.B    #mdAn,opMode    ; Dn or An?
  5010.     BEQ.S    .An
  5011.     BRA.S    loc2
  5012.  
  5013. .An    tst.w    opcode+2-hbase(A4)    ; An.  Are we fetching?
  5014.     bne.s    loc3    ; No
  5015.     move.b    #mdBD,opMode    ; Yes: change to addr, BD mode, zero displ,
  5016.     bset    #6,opBreg    ; with that reg as the base.  This gives
  5017.     clr.b    opind    ; better optimization opportunities.
  5018.     bra.s    loc3    ; NOTE that opReg and opBreg are the same
  5019.             ; byte.
  5020.  
  5021.  
  5022.     hndlr    col_h,0            ; col_h
  5023. .col    BRA    compJSR
  5024.  
  5025.  
  5026. call_h    equ    col_h
  5027. class_h    equ    col_h    ; No difference here, but the different
  5028. class_in_mod_h equ    col_h    ; handler code is needed in various places.
  5029. imported_h    equ    col_h
  5030.  
  5031.  
  5032. ;    ========================
  5033.  
  5034.     hndlr    create_h,0            ; create_h
  5035.     BRA    litAddr1
  5036.  
  5037.     hndlr    builds_h,4            ; builds_h
  5038.     addq.l    #4,(a6)    ; As for Create, but there's
  5039.     bra    litAddr1    ;  an extra 4 bytes before
  5040.             ;  the data field.
  5041.  
  5042. ;    ========================
  5043.  
  5044.     hndlr    obj_h,0            ; obj_h
  5045.     ADDQ.L    #8,(A6)
  5046.     BRA    litAddr1
  5047.  
  5048. ;    ========================
  5049.  
  5050.     hndlr    PushDesc_h,0            ; PushDesc_h
  5051.     bsr    saveOD    ; Called from main compiler if we need
  5052.     pop.l    a1    ;  to push a descriptor whose top 2 bytes
  5053.     lea    ODnew,a0    ;  are given as xinfo.
  5054.     addq.l    #4,a1    ; Skip xinfo flag bytes
  5055.     move.w    (a1)+,(a0)    ; Move type & subtype bytes to new desc
  5056.     move.w    (a1)+,d0    ; Get "real" handler code
  5057.     push.l    a1    ; Push "real" cfa
  5058.     push.w    d0
  5059.     bsr    pushOD
  5060.     pop.w    d0
  5061.     bpl.s    .inline
  5062.  
  5063.     neg.w    d0
  5064.     lea    htable,a0
  5065.     move.w    0(a0,d0.w),d0
  5066.     jmp    0(a4,d0.w)
  5067.  
  5068. .inline    move    d0,-(a6)
  5069.     clr    -(a6)
  5070.     jmp    ncomma
  5071.  
  5072.  
  5073.  
  5074. ; DOES> words have a relocatable addr at the cfa, pointing to the run-time
  5075. ; code to be executed.  The data starts at the cfa+4.  A call to a DOES> word
  5076. ; compiles a LEA of the data addr to A0, followed by a JSR to the run-time code.
  5077. ; At the beginning of the run-time code we compile a push of A0, so we have the
  5078. ; data addr on the stack, as required.
  5079.  
  5080.     hndlr    does_h,4            ; does_h
  5081. ; ( cfa -- )
  5082.     move.l    (a6),-(a6)
  5083.     addq.l    #4,(a6)
  5084.     move.w    #$41C0,d0
  5085.     bsr    OpAndAddr    ;    LEA    <cfa+4>,A0
  5086.     move.l    (a6),a0
  5087.     jsr    doPAtAbs
  5088.     move.l    a0,(a6)
  5089.     bra    compJSR    ;    JSR    <run-time code>
  5090.  
  5091. FixDoes
  5092.     bsr    initODs
  5093.     move.b    #mdBD,opMode
  5094.     move.b    #AnReg,opBreg
  5095.     clr.b    opind
  5096.     bra    FtchVal1
  5097.  
  5098.  
  5099. ;    ========================
  5100.  
  5101.  
  5102. ; SWAP_H handles SWAP.  We optimize the case where the swap is preceded
  5103. ; by two fetches.  This may not seem likely to occur, but it actually
  5104. ; can occur quite readily with inline definitions.
  5105.  
  5106.     hndlr    swap_h,4            ; swap_h
  5107.     addq.l    #4,(a6)    ; Skip xinfo flag bytes
  5108.     bsr    saveOD
  5109.     jsr    length
  5110.     pop.l    d4    ; Save descriptor code in D4
  5111.     lea    ODsav,a0    ; Look at previous op
  5112.     cmp.b    #otFetch,(a0)    ; Fetch?
  5113.     bne.s    .no    ; No: don't optimize
  5114.     move.l    a0,a1    ; Yes: save desc addr in A1
  5115.     downOD        ; Look at op before that
  5116.     cmp.b    #otFetch,(a0)    ; Fetch?
  5117.     bne.s    .no    ; No: don't opt
  5118.     tst.b    opBreg
  5119.     bmi.s    .no    ; Yes, but base or index regs are stack, so
  5120.     tst.b    opXreg    ;  don't opt.
  5121.     bmi.s    .no    ; Note, if this had happened with the other
  5122.             ;  desc, this desc here would have been
  5123.             ;  absorbed. So then it wouldn't have been
  5124.             ;  here at all!  So we didn't need to test 
  5125.             ;  there.
  5126.  
  5127.     addq    #4,a6    ; All OK: we'll optimize.  Drop SWAP cfa
  5128.     backDP
  5129.     bsr    exgOD    ; Swap the descriptors
  5130.     MarkDP
  5131.     bsr    CompFetch    ; And compile them in reverse order.  This
  5132.     upOD        ;  has the same effect as the SWAP, for free
  5133.     MarkDP
  5134.     bsr    CompFetch
  5135.     ODvalid        ; OD is valid
  5136.     rts
  5137.  
  5138. .no    pop.l    a0    ; No optimization.  Get inline code addr
  5139.     push.l    (a0)+
  5140.     jsr    comma    ; And compile the 8 bytes.
  5141.     push.l    (a0)+
  5142.     jsr    comma
  5143.     lea    ODnew,a0
  5144.     move.w    d4,(a0)
  5145.     bra    pushOD    ; Push "swap" descriptor
  5146.  
  5147.  
  5148. ;    ========================
  5149.  
  5150.  
  5151. ; PM_H is the handler for these operations:  + - and or xor.
  5152.  
  5153.     loc
  5154.  
  5155. pmOptFlg    byte
  5156. pmRevFlg    byte
  5157. pmChnFlg    byte
  5158. revFlg    byte
  5159.  
  5160.     align
  5161.  
  5162.     hndlr    pm_h,0            ; pm_h
  5163.     addq.l    #4,(a6)    ; Skip xinfo flag bytes
  5164.     st    pmOptFlg-hbase(A4)
  5165.     sf    pmRevFlg-hbase(A4)
  5166.     move.b    #stk,pmChnFlg-hbase(A4)    ; Means no chaining yet
  5167.     pop.l    a0    ; Look at xinfo stuff
  5168.     move.b    1(a0),operation-hbase(a4)
  5169.     move.b    opShiftCnt,shiftCnt-hbase(a4)
  5170.     bsr    SaveOD
  5171.     move.b    #stk,opMode    ; Assume dst operand is stk, for now
  5172. pmSetupDone
  5173. .pmchk    bsr    ChkOpt
  5174.     beq    .noOpt
  5175.     lea    ODsav,A0
  5176.     cmp.b    #otFetch,(a0)
  5177.     beq    .pmF
  5178.     cmp.b    #otSWAP,d1
  5179.     beq    .pmSwap
  5180.     cmp.b    #otOVER,d1
  5181.     beq    .pmOver
  5182.     cmp.b    #otPMops,d1
  5183.     blt    .noOpt
  5184.     cmp.b    #otPMend,d1
  5185.     bge    .noOpt
  5186.  
  5187. ; Previous op is another pm-type op.  We'll chain them, by recompiling
  5188. ; the first op to dest Dn (usually D1), then compiling the second op with
  5189. ; Dn as src and stk as dest.
  5190.  
  5191.     move.b    operation,d2
  5192.     swap    d2
  5193.     move.b    shiftCnt,d2
  5194.     push.l    d2    ; Save Operation and ShiftCnt
  5195.     moveq    #1,d0
  5196.     bsr    op2Reg    ; Recompile first op to Dn
  5197.     move.b    d0,pmChnFlg-hbase(A4)    ; Indicates chaining on Dn
  5198.     pop.l    d2    ; Restore Operation & ShiftCnt
  5199.     move.b    d2,shiftCnt-hbase(a4)
  5200.     swap    d2
  5201.     move.b    D2,operation-hbase(A4)
  5202.     lea    ODnew,a0
  5203.     markdp
  5204.     move.b    #mdDn,opMode    ; Set up desc for Dn in ODnew
  5205.     move.b    d0,opReg
  5206.     cmp.b    #otMon,D2
  5207.     bge.s    .pmchnMon    ; If this op is a monadic 
  5208.     cmp.b    #otSUB,D2
  5209.     bne.s    .pmchn1
  5210.     tst.b    pmRevFlg-hbase(A4)
  5211.     bne.s    .pmchnR
  5212.     
  5213. .pmchn1    BSR    newClrOD
  5214.     MOVE.B    #stk,opMode
  5215.     MOVE.L    A0,A1
  5216.     LEA    ODnew,A0
  5217.     BSR    OP2
  5218.     BSR    releaseOD
  5219.     BRA    .pmPsh
  5220.  
  5221. .pmchnR    compop    xSubD1
  5222. .pmMv    compop    xmvD1stk
  5223.     BRA    .pmPsh
  5224.  
  5225. .pmchnMon            ; It's a monadic operation.
  5226.     move.l    a0,a1    ; D1 is operand (ODnew)
  5227.     bsr    OP2
  5228.     compop    xPushD1    ; Compile  PUSH.L  D1
  5229.     bra    .pmPsh
  5230.  
  5231. ; Prev op is a fetch.
  5232.  
  5233. .pmF    cmp.b    #otMon,operation-hbase(A4)
  5234.     bge    .noOpt    ; If a monadic op, can't opt on a fetch
  5235.  
  5236.     BackDP        ; Absorb fetch
  5237.     cmp.b    #mdLit,opMode
  5238.     beq.s    .pmLit    ; If a literal
  5239.     cmp.b    #mdX,opMode
  5240.     bhi.s    .pm1
  5241.     tst.b    opind
  5242.     beq    .pmAd2    ; If it's an addr fetch
  5243.     bra.s    .pm1
  5244.  
  5245. .pmLit    ; Literal.  All normal optimization will be handled by OP2,
  5246.     ; so here we only check for zero.  Yes, this can happen!  Probably
  5247.     ; the most common situation will be when we are adding base offsets to
  5248.     ; an object's address when generating the binding code.  These offsets
  5249.     ; will often be zero.  The operation is always addition, but it's
  5250.     ; just as easy to include subtraction and OR here as well.
  5251.     ; In these cases, we just leave the DP backed, pop the descriptors
  5252.     ; to where they were before the literal zero, and get out without
  5253.     ; compiling anything.  We could also do something about AND,
  5254.     ; but I doubt it's worth it.
  5255.  
  5256.     TST.L    opLit        
  5257.     BNE.S    .pm1
  5258.     cmp.b    #otAND,operation-hbase(A4)
  5259.     BEQ.S    .pm1
  5260.     BSR    popOD
  5261.     RTS
  5262.  
  5263. ; We have (non-addr)-fetch, pm-op.
  5264.  
  5265. .pm1    downOD        ; Look at previous descriptor
  5266.             ; - we may be able to further optimize
  5267.     cmp.b    #otFetch,(a0)
  5268.     beq    .pmFF    ; If another long fetch
  5269.     cmp.b    #otPMops,(a0)
  5270.     blt    .pmUp
  5271.     cmp.b    #otPMend,(a0)
  5272.     bge    .pmUp    ; If not another pm-type op, we can't do
  5273.             ;  anything more
  5274.  
  5275. ; We have pm-op, fetch, pm-op.  We recompile the first pm-op to Dn, then the second
  5276. ; to operate between the addressed location and Dn.  Then we compile a push of Dn
  5277. ; to the stack.  If we next encounter another pm-op, we'll continue the chain,
  5278. ; deleting the push.
  5279.  
  5280.     move.b    operation,d0
  5281.     swap    d0
  5282.     move.b    shiftCnt,d0
  5283.     push.l    d0
  5284.     moveq    #1,d0
  5285.     bsr    op2reg
  5286.     pop.l    d1
  5287.     move.b    d1,shiftCnt-hbase(a4)
  5288.     swap    d1
  5289.     move.b    d1,operation-hbase(A4)
  5290.     upOD
  5291. .pmMark    markDP
  5292.     move.b    d0,d1
  5293.     or.b    #fchChn,d1
  5294.     move.b    d1,pmChnFlg-hbase(A4)    ; Mark as chained with fetched operand
  5295.     LEA    ODnew,A1
  5296.     MOVE.B    #mdDn,opMode(A1)
  5297.     move.b    d0,opReg(a1)
  5298.     BSR    newOD
  5299.     MOVEQ    #1,D0
  5300.     BSR    LoadBase
  5301.     BSR    OP2
  5302.     BSR    releaseOD
  5303.     TST.B    pmRevFlg-hbase(A4)
  5304.     BEQ.S    .pmToStk
  5305.     compop    xNegD1    ; We hope it was really D1!!
  5306. .pmToStk
  5307.     compop    xPushD1
  5308.     BRA    .pmPsh
  5309.  
  5310. ; We have (non-addr)-fetch, fetch, pm-op.  Note, the second fetch CAN be
  5311. ; an addr fetch if the pm-op isn't add.
  5312.  
  5313. .pmFF    cmp.b    #mdX,opMode
  5314.     bhi.s    .pmFF1
  5315.     tst.b    opind
  5316.     beq    .pmAd    ; if 1st operand is an addr fetch
  5317.  
  5318. ; Here we optimize on two preceding fetches -- e.g. val1 val2 + is most
  5319. ; efficiently compiled to
  5320. ;
  5321. ;    move.l    val1,d1
  5322. ;    add.l    val2,d1
  5323. ;    move.l    d1,-(a6)
  5324. ;
  5325. ; but we also check for the fetches both being literal, as in this case we can
  5326. ; do the op now at compile time.
  5327.  
  5328. .pmFF1    backDP
  5329.     cmp.b    #mdLit,opMode
  5330.     bne.s    .pmFF2
  5331.     move.l    opLit,d2
  5332.     upOD
  5333.     cmp.b    #mdLit,opMode
  5334.     beq    .pmLL
  5335.     downOD
  5336.  
  5337. .pmFF2    moveq    #1,d0
  5338.     st    ForceToR-hbase(a4)    ; Force temp D1 to be used
  5339.     bsr    FetchToD
  5340.     UpOD
  5341.     bra.s    .pmMark
  5342.  
  5343. .pmUp    upOD        ; We come here from a few other places too
  5344.     BRA.S    .pmOP2
  5345.  
  5346. .noOpt    UseODsrc        ; Can't optimize
  5347.     MOVE.B    #stkPop,opMode
  5348.     MOVE.B    #Lcode,opSize
  5349.  
  5350. .pmOP2    LEA    ODnew,A1
  5351.     BSR    newOD
  5352.     MOVEQ    #1,D0
  5353.     BSR    LoadBase
  5354.     BSR    OP2    ; Compile operation
  5355.     TST.B    pmRevFlg-hbase(A4)    ; Was it a reversed operation?
  5356.     BEQ.S    .pmTst
  5357.  
  5358.     MOVE.B    #mdDn,opMode    ; Yes - the result will be in Dn
  5359.     MOVE.B    opToFrom,opReg    ;  where n will have been left in
  5360.             ;  opToFrom by OP2.
  5361.     BSR    CompMove    ; This moves it to the stack (A1 desc).
  5362.  
  5363. .pmTst    BSR    ReleaseOD
  5364.     TST.B    pmOptFlg-hbase(A4)
  5365.     BNE.S    .pmPsh
  5366.     RTS
  5367.  
  5368. .pmPsh    LEA    ODnew,A0
  5369.     TST.B    pmRevFlg-hbase(A4)
  5370.     BNE.S    .optRSub
  5371.     move.b    operation,D0
  5372.     BRA.S    .pmPsh1
  5373. .optRSub
  5374.     MOVE.B    #otRevSub,D0
  5375. .pmPsh1    MOVE.B    D0,(A0)    ; Set up the descriptor to push
  5376.     moveq    #0,d0
  5377.     move.b    shiftCnt,d0
  5378.     move.b    d0,opShiftCnt
  5379.     MOVE.B    pmChnFlg,opToFrom
  5380.     BRA    pushOD
  5381.  
  5382.  
  5383. ; Optimization of arithmetic on an address.
  5384. ;
  5385. ; We handle address optimizations in two places.  First, if we get an address
  5386. ; fetch (that is a fetch with opind zero), followed or by some arithmetic, we
  5387. ; detect it here.  We attempt to absorb the arithmetic at compile time, or
  5388. ; if we can't do that, but the operation is add, we see if we can use index
  5389. ; mode or at least LEA the addr to An then add into An.  In the latter 2
  5390. ; cases we generate a new descriptor referencing An and block optimizing
  5391. ; further back.  This is all on the assumption that we're eventually going
  5392. ; to want the result in An -- not unreasonable.
  5393. ; 
  5394. ; The other place where we try to optimize an address is if we didn't
  5395. ; get an address fetch but we get @ or ! preceded by a + or -.  In this
  5396. ; case we look for a preceding literal which can be absorbed into the
  5397. ; address.  We do this at OptAddr later.  
  5398.  
  5399. .pmAd            ; We have an address fetch followed by
  5400.             ;  another fetch.
  5401.     upOD
  5402.     cmp.b    #mdDn,opMode    ; Is following fetch a D reg?
  5403.     bne.s    .pma1
  5404.     cmp.b    #1,opind
  5405.     beq.s    .pmAX    ; Yes - maybe generate index mode
  5406.  
  5407. .pma1    cmp.b    #otSUB,operation-hbase(A4) ; Is op add or subtract?
  5408.     bgt.s    .pmOP2    ; No - don't optimize
  5409.     cmp.b    #mdLit,opMode    ; Is following fetch a literal?
  5410.     bne.s    .pmOP2    ; No - don't optimize here 
  5411.             ;  (but may do it later)
  5412.  
  5413. ; We have addr fetch, literal, add/sub.  We absorb the literal add or sub into
  5414. ; the address at compile time.
  5415.  
  5416.     sf    pmOptFlg-hbase(a4)    ; We're optimizing now, so don't do it again
  5417.     move.l    opLit,d1
  5418.     downOD
  5419.     move.l    opDispl,d0
  5420. ;    ext.l    d0
  5421.     cmp.b    #otSUB,operation-hbase(a4)
  5422.     beq.s    .pmaSub
  5423.     add.l    d1,d0
  5424.     bra.s    .pma2
  5425. .pmaSub    sub.l    d1,d0
  5426. .pma2    upOD
  5427.     BSR    popOD    ; Fix descriptors - absorb 2nd fetch
  5428.     LEA    ODsav,A0
  5429.     BackDP
  5430.     move.l    d0,opDispl
  5431.     bra.s    .pmCF
  5432.  
  5433. ; We have addr fetch, D reg fetch, add/sub.  If it's an add, we can generate
  5434. ; an index mode.
  5435.  
  5436. .pmAX
  5437.     cmp.b    #otADD,operation-hbase(A4)
  5438.     BNE    .pmOP2    ; We can only convert to index if it's add
  5439.     sf    pmOptFlg-hbase(a4)    ; We're optimizing now, so don't do it again
  5440.     MOVE.B    opReg,D3
  5441.     BSR    popOD    ; Fix descriptors - absorb reg fetch
  5442.     LEA    ODsav,A0
  5443.     BackDP
  5444.     MOVE.B    #mdX,opMode
  5445.     MOVE.B    D3,opXreg
  5446. .pmCF    BSR    CompFetch    ; Now recompile the address fetch
  5447.     ODvalid
  5448.     RTS        ; OD is valid, and we're done.
  5449.  
  5450. ; 2nd operand is an address fetch.
  5451.  
  5452. .pmAd2    cmp.b    #otADD,operation-hbase(a4) ; We can only do addr optimization if
  5453.     bne    .pm1    ;  the op is add. Otherwise just treat
  5454.             ;  as an ordinary fetch.
  5455.     downOD
  5456.     cmp.b    #otFetch,(a0)
  5457.     beq.s    .pmFad2    ; If previous desc is a fetch
  5458.     sf    pmOptFlg-hbase(a4)    ; We're optimizing now, so don't do it again
  5459.     cmp.b    #otPMops,(a0)
  5460.     blt    .pmNad2
  5461.     cmp.b    #otPMend,(a0)
  5462.     bge    .pmNad2    ; If not recognizable
  5463.  
  5464. ; We have an integer arith op followed by an addr fetch to be added.
  5465.  
  5466.     moveq    #1,d0
  5467.     bsr    op2Reg    ; Recompile arith op to D1
  5468.     lea    ODsav,a0
  5469.     moveq    #0,d0    ; Compile:
  5470.     bsr    LoadBase
  5471.     get.l    DP,d0
  5472.     moveq    #0,d0
  5473.     bsr    CompLEA    ;    lea    <addr>,a0
  5474.     get.l    DP,d0
  5475.     compop    xAddD1A0    ;    add.l    d1,a0
  5476.     lea    ODsav,a0
  5477. .A0ind    move.b    #mdBD,opMode    ; Change descriptor to A0 indirect
  5478.     move.b    #AnReg,opBreg    ; - actually BD mode, A0 base, zero displ.
  5479.     clr.l    opDispl
  5480.     resetDP        ; Can't opt further back now, since we
  5481.             ;  just compiled special code
  5482.     bra    .pmCF    ; Recompile the address fetch using the
  5483.             ;  modified descriptor, and out.
  5484.  
  5485. ; We have a fetch followed by an addr fetch to be added.
  5486.  
  5487. .pmFad2    backDP        ; We recompile in the reverse order
  5488.     move.l    a0,a1    ;  so the .pmAd code above can handle it.
  5489.     upOD        ; Note that we mightn't necessarily end up
  5490.     bsr    ExgOD    ;  optimizing, so we leave pmOptFlg alone
  5491.     downOD        ;  for now.
  5492.     get.L    DP,opDP
  5493.     bsr    CompFetch
  5494.     bra    .pmAd
  5495.  
  5496. ; We have nothing recognizable followed by an address fetch to be added.
  5497. ; We just add whatever is on the top of the stack at run time.
  5498.  
  5499. .pmNad2    lea    ODsav,a0
  5500.     moveq    #0,d0    ; Compile:
  5501.     bsr    LoadBase
  5502.     get.l    DP,d0
  5503.     moveq    #0,d0
  5504.     bsr    CompLEA    ;    lea    <addr>,a0
  5505.     get.l    DP,d0
  5506.     compop    xAddStkA0    ;    add.l    (a6)+,a0
  5507.     bra    .A0ind    ; Change desc to A0 indirect, etc.
  5508.  
  5509. ; Previous op was SWAP.  We absorb it.
  5510.  
  5511. .pmSwap    cmp.b    #otSUB,operation-hbase(A4)
  5512.     BNE.S    .notSub
  5513.     EOR.W    #$100,RevOpnds-hbase(A4)
  5514.     SNE    pmRevFlg-hbase(A4)
  5515.  
  5516. .notSub    backDP
  5517.     LEA    ODnew,A0
  5518.     resetDP
  5519.     BSR    dropOD
  5520.     BRA    .pmchk
  5521.  
  5522. ; Previous op was OVER.  We compile a  MOVE.L  4(A6),D0
  5523. ; then call OP2 with the 2nd operand in D0 at run time.
  5524.  
  5525. .pmOver    backDP
  5526.     compopl    xMv2ndD0
  5527.     lea    ODreg,a0
  5528.     move.b    #mdDn,opMode
  5529.     move.b    #Lcode,opSize
  5530.     clr.b    opReg
  5531.     bsr    .pmOP2
  5532.     NoOpt
  5533.     rts
  5534.  
  5535. .pmLL    move.l    opLit,d1
  5536.     downOD
  5537.     backDP
  5538.     move.l    opLit,d0
  5539.     moveq    #0,d2
  5540.     move.b    operation,d2
  5541.     lsl.w    #1,d2
  5542.     lea    xadds-(otADD*2),a0
  5543.     move.w    0(a0,d2.w),d2
  5544.     or.w    #$81,d2    ; Make it  XXX.L  d1,d0
  5545.     move.w    d2,.doit-hbase(a4)    ; Store op for execution
  5546.     bsr    FlushCache
  5547. .doit    _debugger
  5548.     bsr    popOD
  5549.     lea    ODsav,a0
  5550.     move.l    d0,opLit
  5551.     bra    CompFetch
  5552.  
  5553.  
  5554. ;        ===================
  5555.  
  5556. ; MultDiv_h ( ^code -- ) handles * *W and /.  The only special action we take
  5557. ; is to check for two preceding literal fetches, so we can do the op now at
  5558. ; compile time.
  5559.  
  5560.     hndlr    MultDiv_h,4            ; MultDiv_h
  5561.     loc
  5562.     addq.l    #4,(a6)    ; Skip xinfo flag bytes
  5563.     move.l    (a6),a0
  5564.     move.b    1(a0),operation-hbase(a4)    ; Get operation
  5565.     bsr    saveOD
  5566.     bsr    chkOpt
  5567.     beq.s    .noOpt
  5568.     lea    ODsav,a0
  5569.     cmp.b    #otFetch,(a0)
  5570.     bne.s    .noOpt
  5571.     cmp.b    #mdLit,opMode
  5572.     bne.s    .noOpt
  5573.     move.l    opLit,d2
  5574.     downOD
  5575.     cmp.b    #otFetch,(a0)
  5576.     bne.s    .noOpt1
  5577.     cmp.b    #mdLit,opMode
  5578.     bne.s    .noOpt1
  5579.     backDP
  5580.     addq    #4,a6
  5581.     push.l    a0
  5582.     push.l    opLit
  5583.     push.l    d2
  5584.     cmp.b    #otDIV,operation-hbase(a4)
  5585.     beq.s    .mdDiv
  5586.     jsr    star
  5587. .md1    pop.l    d0
  5588.     pop.l    a0
  5589.     move.l    d0,opLit
  5590.     bsr    popOD
  5591.     lea    ODsav,a0
  5592.     bra    CompFetch
  5593.  
  5594. .mdDiv    jsr    slash
  5595.     bra.s    .md1
  5596.  
  5597. .noOpt1    upOD
  5598. .noOpt    addq.l    #2,(a6)
  5599.     bra    CompJSR
  5600.  
  5601.  
  5602. ; FP2_h ( ^code -- )  handles dyadic floating-point ops.  It is rather
  5603. ; like pm_h but a lot simpler (well, a little bit simpler?) because we don't
  5604. ; have to check for as many different possibilities.
  5605.  
  5606.     hndlr    FP2_h,4            ; FP2_h
  5607.     loc
  5608.     sf    pmRevFlg-hbase(a4)
  5609.     get.l    useFPUq,d0    ; Are we compiling FPU code?
  5610.     bne.s    .fpFPU
  5611.     addq.l    #2,(a6)    ; No - skip the opcode and just compile
  5612.     bra    CompJSR    ;  a call to what follows there.
  5613.  
  5614. .fpFPU    clr.b    FPA-hbase(a4)
  5615.     pop.l    a0
  5616.     move.b    1(a0),operation-hbase(a4)
  5617.     move.b    #stk,pmChnFlg-hbase(A4)
  5618.     bsr    saveOD
  5619.     move.b    #stk,opMode    ; Assume dst operand is stack, for now
  5620. .fpChk    bsr    chkOpt
  5621.     lea    ODsav,a0
  5622.     beq    .noOpt
  5623.     cmp.b    #otFetch,d1
  5624.     beq    .fpF
  5625. ;    cmp.b    #otSWAP,d1    ; NOTE: as yet, we're not handling 
  5626.             ;  optimization of SWAP with FP operations
  5627. ;    beq    .fpSwap    ;  as it complicates things a lot,
  5628.             ;  and probably isn't worth it.
  5629.     cmp.b    #otFPops,d1
  5630.     blt    .noOpt
  5631.     cmp.b    #otFPend,d1
  5632.     bge    .noOpt
  5633.  
  5634. ; Preceding op was another FP op.  Chain them.
  5635.  
  5636. fpChain
  5637.     move.b    operation,d0
  5638.     push.w    d0
  5639.     moveq    #1,d0
  5640.     bsr    FPop2reg    ; Recompile preceding op to FP0 or FP1
  5641.     move.b    d0,pmChnFlg-hbase(a4)
  5642.     pop.w    d1
  5643.     move.b    d1,operation-hbase(a4)
  5644.     lea    ODnew,a0
  5645.     markDP
  5646.     move.b    #mdFPn,opMode
  5647.     move.b    #fbFP,opFlags
  5648.     move.b    d0,opReg
  5649.     cmp.b    #otFPmon,d1
  5650.     bge.s    .fpChnMon
  5651.  
  5652. ;    cmp.b    #otFPnoncom,operation-hbase(a4)
  5653. ;    blt.s    .fpchn1    ; At the moment we're not optimizing
  5654. ;    tst.b    pmRevFlg-hbase(a4)    ; FP operands over SWAP, so no reversed
  5655. ;    bne.s    .fpChnR    ; ops can occur.
  5656.  
  5657. .fpchn1    bsr    newClrOD
  5658.     move.b    #stk,opMode
  5659.     clr.b    FPdispFlg-hbase(a4)
  5660.     move.l    a0,a1
  5661.     lea    ODnew,a0
  5662.     clr.b    FPA-hbase(a4)
  5663.     bsr    OP2
  5664.     bsr    releaseOD
  5665.     bra    fpPsh
  5666.  
  5667. ;.fpChnR    dc.w    $FFE4
  5668.  
  5669. .fpChnMon
  5670.     move.l    a0,a1    ; Same FPn (ODnew) is both src and dst
  5671.     bsr    OP2
  5672.     bsr    newClrOD    ; Compile a move of result to a new FP heap
  5673.     move.b    #stkPush,opMode    ;  block, and a push of the address.
  5674.     exg    a0,a1
  5675.     bsr    ToNewHeap
  5676.     bsr    releaseOD
  5677.     bra    fpPsh
  5678.  
  5679. ; Preceding op was a fetch.
  5680.  
  5681. .fpF    cmp.b    #otFPmon,operation-hbase(a4)
  5682.     bge    .noOpt
  5683.     backDP
  5684.     btst    #flLit,opFlags
  5685.     sne    d2    ; Remember in D2 if it was a floating literal
  5686.     downOD        ; What was op before that?
  5687.     cmp.b    #otFetch,(a0)
  5688.     beq    .fpFF    ; Another fetch
  5689.     cmp.b    #otFPops,(a0)
  5690.     blt    .fpUp
  5691.     cmp.b    #otFPend,(a0)
  5692.     bge    .fpUp    ; If not a FP op, we can't do anything more
  5693.  
  5694. ; We have  FP op, fetch, FP op.
  5695.  
  5696.     move.b    d2,usePrevFPlit-hbase(a4)
  5697.         ; If last fetch was an FP lit, and the following recompilation finds a 
  5698.         ; literal fetch, it will be the previous value.
  5699.     move.b    operation,d0
  5700.     push.w    d0
  5701.     moveq    #1,d0
  5702.     BSR    FPop2Reg    ; Recompile first FP op to FP0 or FP1
  5703.     sf    usePrevFPlit-hbase(a4)
  5704.     pop.w    d1    ; Restore everything
  5705.     move.b    d1,operation-hbase(A4)
  5706.     upOD
  5707. .fpMark    markDP
  5708.     move.b    d0,d6    ; Save reg# in D6
  5709.     move.b    d0,d1
  5710.     or.b    #fchChn,d1
  5711.     move.b    d1,pmChnFlg-hbase(A4) ; Mark as chained with fetched operand
  5712.     lea    ODnew,a1
  5713.     move.b    #mdFPn,opMode(a1)
  5714.     move.b    d0,opReg(a1)
  5715.     move.b    #fbFP,opFlags(a1)
  5716.     bsr    newOD
  5717.     moveq    #1,d0
  5718.     bsr    LoadBase
  5719.     clr.b    FPA-hbase(a4)
  5720.     bsr    OP2
  5721.     bsr    releaseOD
  5722.     bsr    compFPnew
  5723.     move.b    #$80,d1
  5724.     tst.b    d6
  5725.     beq.s    .fpF1
  5726.     move.b    #$40,d1
  5727. .fpF1    move.l    #$F210F000,d0    ;    fmovem    fp0,(a0)
  5728.     or.b    d1,d0    ; Fix source reg#
  5729.     push.l    d0
  5730.     jsr    comma
  5731.     compop    xpushA0
  5732.     bra    fpPsh
  5733.  
  5734. ; Here we optimize on two preceding fetches.
  5735.  
  5736. .fpFF    btst    #flFP,opFlags    ; Was 1st one floating?
  5737.     beq.s    .fpUp    ; No
  5738.     backDP
  5739.     move.b    d2,usePrevFPlit-hbase(a4)
  5740.             ; If both fetches are literal, the following
  5741.             ; CompMoveToFPn call must use the earlier
  5742.             ; value.  Maybe we can do this calculation
  5743.             ; at compile time later?
  5744.     moveq    #1,d0
  5745.     clr.b    FPA-hbase(a4)
  5746.     bsr    CompMoveToFPn
  5747.     sf    usePrevFPlit-hbase(a4)
  5748.     UpOD
  5749.     moveq    #1,d0    ; It was FP1 we used
  5750.     bra.s    .fpMark
  5751.  
  5752. .fpUp    upOD
  5753.     bra.s    .fpOP2
  5754.  
  5755. .noOpt    UseODsrc        ; Can't optimize
  5756.     move.b    #stkPop,opMode
  5757.     move.b    #1,FPdispFlg-hbase(a4) ; One operand to dispose
  5758.  
  5759. .fpOP2    lea    ODnew,a1
  5760.     bsr    newOD
  5761.     moveq    #0,d0
  5762.     bsr    loadBase
  5763.     clr.b    FPA-hbase(a4)
  5764.     bsr    OP2
  5765.     bsr    releaseOD
  5766.  
  5767. fpPsh    move.b    operation,d0
  5768.     lea    ODnew,a0
  5769.     move.b    operation,(a0)
  5770.     move.b    pmChnFlg,opToFrom
  5771.     move.b    pmRevFlg,opSubType    ; Will be NZ if op is reversed by SWAP
  5772.     move.l    FPDP,opFPDP
  5773.     bra    PushOD
  5774.  
  5775. ; Previous op was SWAP.  NOT YET!!!
  5776.  
  5777. ;.fpSwap    cmp.b    #otFPnoncom,operation-hbase(A4)
  5778. ;    blt.s    .comm
  5779. ;    eor.w    #$100,RevOpnds-hbase(A4)
  5780. ;    sne    pmRevFlg-hbase(A4)
  5781.  
  5782. ;.comm    backDP
  5783. ;    lea    ODnew,A0
  5784. ;    resetDP
  5785. ;    bsr    dropOD
  5786. ;    bra    .fpChk
  5787.  
  5788. ;        ===================
  5789.  
  5790. ; FP monadic ops.  In the case of fabs and fnegate, these are so easy
  5791. ; to do in main memory that we only use the FP regs if the operand is already
  5792. ; there, or if it is going to be stored there.  The latter case we can't
  5793. ; determine now, so if an FP fetch or operation doesn't precede, we just
  5794. ; push a descriptor and compile the default JSR.  Then the store routine will
  5795. ; see the descriptor and optimize if the destination is an FP location.
  5796.  
  5797.     hndlr    FP1_h,4
  5798.     loc
  5799.     move.l    (a6),a0
  5800.     move.b    1(a0),operation-hbase(a4)
  5801.     get.l    useFPUq,d0    ; Are we compiling FPU code?
  5802.     bne.s    .fpmFPU
  5803. .noOpt    addq.l    #2,(a6)    ; No - skip the opcode and just compile
  5804.     bsr    CompJSR    ;  a call to what follows there.
  5805.     bra    fpPsh    ; Push descriptor
  5806.  
  5807. .fpmFPU    clr.b    FPA-hbase(a4)
  5808.     move.b    #stk,pmChnFlg-hbase(A4)
  5809.     bsr    saveOD
  5810.     move.b    #stk,opMode    ; Assume dst operand is stack, for now
  5811. .fpChk    bsr    chkOpt
  5812.     lea    ODsav,a0
  5813.     beq.s    .noOpt
  5814.     cmp.b    #otFetch,d1
  5815.     beq.s    .fpmF
  5816.     cmp.b    #otFPops,d1
  5817.     blt.s    .noOpt
  5818.     cmp.b    #otFPend,d1
  5819.     bge.s    .noOpt
  5820.  
  5821. ; Yes, we'll do it!
  5822.  
  5823. .fpmDoit
  5824.     addq    #4,a6
  5825.     bra    fpChain
  5826.  
  5827. ; A fetch preceded.
  5828.  
  5829. .fpmF    btst    #flFP,opFlags    ; Was it an FP operand?
  5830.     beq.s    .noOpt    ; No
  5831.     addq    #4,a6    ; Yes
  5832.     backDP
  5833.     lea    ODnew,a1
  5834.     move.b    #stkPush,opMode(a1)
  5835.     bsr    OP2
  5836.     bra    fpPsh
  5837.  
  5838. ;        ===================
  5839.  
  5840. ; FPcmp_h handles floating-point compares.
  5841.  
  5842.     hndlr    FPcmp_h,4                ; FPcmp_h
  5843.     loc
  5844.     get.l    useFPUq,d0    ; Are we compiling FPU code?
  5845.     bne.s    .fcFPU
  5846. .noOpt    addq.l    #2,(a6)    ; No - skip the opcode and just compile
  5847.     bsr    CompJSR    ;  a call to what follows there.
  5848.     bra    .fpcPsh    ; Push descriptor
  5849.  
  5850. .fcFPU    clr.b    FPA-hbase(a4)
  5851.     clr.b    RCond-hbase(a4)
  5852.     bsr    saveOD
  5853.     pop.l    a1
  5854.     move.w    (a1),(a0)    ; Set up comparison desc in ODnew
  5855.     bsr    CompFCMP
  5856.     moveq    #0,d0
  5857.     move.w    #$F240,d0    ; FScc opcode
  5858.     swap    d0
  5859.     move.b    condition,d0
  5860.     move.b    RCond,d1
  5861.     clr.b    RCond-hbase(a4)    ; An extra clear never hurt anyone
  5862.     eor.b    d1,d0
  5863.     lea    int2FPconditions,a0
  5864.     move.b    0(a0,d0.w),d0
  5865.     push.l    d0    ; Compile:
  5866.     jsr    comma    ;     FScc
  5867.     push.l    #$49C02D00    ;     extb.l    d0
  5868.     jsr    comma    ;    push.l    d0
  5869.  
  5870. .fpcPsh    lea    ODnew,a0
  5871.     bra    PushOD
  5872.  
  5873.  
  5874. ;        ===================
  5875.  
  5876.     hndlr    shift_h,4    ; Handler for LSHIFT, RSHIFT
  5877.     addq.l    #4,(a6)    ; Skip xinfo flag bytes
  5878.     jsr    length
  5879.     pop.l    d4    ; Save opcode in D4
  5880.     bsr    saveOD
  5881.     lea    ODsav,a0    ; Look at previous op (shift count)
  5882.     cmp.b    #otFetch,(a0)    ; Is it a fetch?
  5883.     bne.s    .sh1    ; No: don't optimize
  5884.     cmp.b    #mdLit,opMode
  5885.     bne.s    .sh1    ; Or if it isn't literal
  5886.     cmp.l    #8,opLit
  5887.     bgt.s    .sh1    ; Or if count > 8 (limit for literal shifts)
  5888.     tst.w    opLit
  5889.     bmi.s    .sh1    ; Or negative
  5890.  
  5891.     backDP        ; Otherwise we'll optimize.
  5892.  
  5893. ; Optimizing a shift means absorbing the constant in the shift op, which
  5894. ; makes it in effect become a monadic operation.  But it isn't like other
  5895. ; monadics, since it can only operate on a D reg.  We take care of this
  5896. ; in OP2.
  5897.     addq    #4,a6    ; Drop cfa
  5898.     move.l    opLit,d5    ; Get literal value to D5
  5899.     bsr    popOD    ; drop the literal desc
  5900.     lea    ODnew,a0
  5901.     move.w    d4,(a0)    ; Set new desc type and mode
  5902.     move.b    #stk,opMode
  5903.     tst.b    d4    ; We use a -ve shift cnt to mean right
  5904.     beq.s    .sh0
  5905.     neg.b    d5
  5906. .sh0    move.b    d5,opShiftCnt
  5907.     move.b    d5,shiftCnt-hbase(a4)
  5908.     st    pmOptFlg-hbase(A4)    ; set up for going to pm_h
  5909.     sf    pmRevFlg-hbase(A4)
  5910.     move.b    #stk,pmChnFlg-hbase(A4)
  5911.     move.b    opType,operation-hbase(a4)
  5912.     bra    pmSetupDone
  5913.  
  5914. .sh1    bra    compJSR    ; can't opt - compile the JSR
  5915.  
  5916.  
  5917.     hndlr    bit_h,4    ; Handler for BSET, BRESET, BTOGGLE
  5918.     addq.l    #4,(a6)    ;  and BTEST
  5919.     jsr    length
  5920.     pop.l    d4    ; Opcode to D4
  5921.     bsr    saveOD
  5922.     lea    ODsav,a0    ; Look at previous op (bit offset #)
  5923.     cmp.b    #otFetch,(a0)    ; Is it a fetch?
  5924.     bne    .b1    ; No: don't optimize
  5925.     cmp.b    #mdLit,opMode    ; Yes: is it literal?
  5926.     bne    .b1    ; No: don't optimize
  5927.  
  5928.     backDP        ; Yes: we'll optimize.
  5929.     addq    #4,a6    ; Drop cfa
  5930.     move.l    opLit,d5    ; Get literal value to D5
  5931.     move.l    d5,d6
  5932.     lsr.l    #3,d6    ; Byte offset value to D6
  5933.     downOD        ; Look at prev op (base addr)
  5934.     cmp.b    #otFetch,(a0)    ; Fetch?
  5935.     bne.s    .popA0    ; No: compile a pop to A0
  5936.  
  5937.     backDP        ; Yes
  5938.     tst.b    opind    ; Is it an addr fetch?
  5939.     bne.s    .f2a    ; No
  5940.     move.l    d6,d0    ; Yes - we'll recompile it as
  5941.     bsr    offsetAddr    ;  the appropriate bit op.  Adjust addr
  5942.     lea    ODnew,a1
  5943.     bsr    moveDesc    ; Move the desc to ODnew since we
  5944.     lea    ODnew,a0    ; might want to push it at the end
  5945.     bra.s    .bop
  5946.     
  5947. .f2a    moveq    #AnReg,d0    ; Addr wasn't an addr fetch.
  5948.     bsr    FetchToA    ; Recompile fetch to A0.
  5949.     upOD
  5950.     bra.s    .b0    ; Set (a0) as address
  5951.  
  5952. .popA0    compop    xPopA0    ; No fetch descriptor for base address.
  5953.  
  5954. .b0    lea    ODnew,A0    ; We come here if we need to make (a0) the
  5955.     move.b    #mdBD,opMode    ;  base address.
  5956.     move.b    #AnReg,opBreg
  5957.     move.l    d6,opDispl
  5958. .bop    move.w    d4,(a0)    ; We enter here if the addr is OK already
  5959.     move.w    #$0800,d0    ; Static bit op opcode
  5960.     and.w    #$3,d4
  5961.     move.w    d4,d1
  5962.     lsl.w    #6,d1
  5963.     or.w    d1,d0    ; Insert op type (BTST, BCLR or whatever)
  5964.     bsr    EAbits
  5965.     swap    d0
  5966.     and.w    #$7,d5    ; Put bit number in
  5967.     move.w    d5,d0
  5968.     push.l    d0
  5969.     jsr    comma    ; Compile operation
  5970.     bsr    CompExt
  5971.     tst.b    d4    ; Is it BTST?
  5972.     bne.s    .out    ; No: we're finished
  5973.     get.L    xPushBool,-(a6)    ; Yes: compile a JSR to the pushBool routine
  5974.     bsr    comma    ;  to get a boolean flag onto the stack
  5975.     bsr    pushOD    ; And in this case we push the desc so that
  5976. .out    rts        ;  a following IF can optimize.
  5977.  
  5978. .b1    bsr    compJSR    ; No optimization.  Compile JSR to bit op
  5979.     rts        ;  routine
  5980.  
  5981.  
  5982. ;        ====================
  5983.  
  5984. ;              OPTADDR
  5985.  
  5986. ;        ====================
  5987.  
  5988. ; We handle address optimizations in two places.  First, if we get an address
  5989. ; fetch (that is a fetch with opind zero), followed by some arithmetic, we
  5990. ; detect this in PM_H and try various optimizations.  See the comments there,
  5991. ; at label .pmAd .
  5992. ;
  5993. ; Secondly, something may be used as an address (via @ or !) which didn't
  5994. ; have an address fetch component within it - e.g. if an address is grabbed
  5995. ; out of a value etc.  If this quantity then has a literal added to or subtracted
  5996. ; from it, we could absorb this operation within the address.  PM_H can't know
  5997. ; about this, so we handle it here.
  5998. ;
  5999. ; This routine is called from at_h and store_h, if the preceding op is + or -.
  6000. ; Here we check if the descriptor before that indicates a literal operand.
  6001. ; If so, we absorb it.
  6002. ;
  6003. ; Assumes the add/sub descriptor is in ODsav, and the descriptor for the
  6004. ; fetch or store in ODnew.  A0 isn't preserved.
  6005.  
  6006. LitSub    byte
  6007. LitChained
  6008.     byte
  6009.     align
  6010.  
  6011. optAddr    loc
  6012.     lea    ODsav,a0
  6013.     cmp.b    #otSUB,(A0)
  6014.     seq    LitSub-hbase(A4)    ; Set flag if op is SUB
  6015.     tst.b    opToFrom
  6016.     sge    LitChained-hbase(a4)    ; Set flag if it's a chained op
  6017.     DownOD        ; Look at preceding op
  6018.     cmp.b    #otFetch,(a0)    ; Fetch?
  6019.     bne    .no    ; No
  6020.     cmp.b    #mdLit,opMode    ; Yes: literal?
  6021.     bne    .oaNotLit    ; No
  6022.  
  6023. ; Literal precedes.  We can optimize.
  6024.  
  6025. .oaLit    move.l    opLit,d6    ; Save lit value
  6026.     BackDP
  6027.     tst.b    LitSub-hbase(a4)
  6028.     beq.s    .oa1
  6029.     neg.l    d6    ; Negate lit value if op is SUB
  6030. .oa1    push.l    a0
  6031.     lea    ODnew,a0
  6032.     move.b    #mdBD,opMode    ; Mode = BD
  6033.     add.l    d6,opDispl    ; Adjust displacement by lit value
  6034.     pop.l    a0
  6035.     DownOD        ; Look at preceding op
  6036.     cmp.b    #otFetch,(A0)    ; Fetch?
  6037.     beq.s    .oa3    ; Yes.  We can disregard chaining flag,
  6038.             ;  since we're going to recompile the
  6039.             ;  whole thing anyway.
  6040.     tst.b    LitChained-hbase(a4)    ; No. Was op chained?
  6041.     beq.s    .oa2    ; No.
  6042.     compop    xMvD1A0    ; Yes - addr will be in D1 - compile
  6043.             ;  a move to A0
  6044.     bra.s    .clrbr    ; Set base reg to A0, and out.
  6045.  
  6046. .oa2    lea    ODnew,a0    ; No.  Leave base reg as stack - this
  6047.     bra.s    .rsdp    ;  will result in a pop to A0 being
  6048.             ;  compiled before the fetch/store.
  6049.  
  6050. .oa3    cmp.b    #mdDn,opMode    ; Two fetches.  Is the first Dn?
  6051.     beq.s    .oaD    ; Yes
  6052.     BackDP        ; No.  Recompile fetch to go to A0
  6053.     moveq    #0,d0
  6054.     bsr    FetchToA
  6055.  
  6056. .clrbr    lea    ODnew,A0    ; Finally we fix ODnew descriptor:
  6057.     move.b    #AnReg,opBreg    ; Base reg = A0
  6058. .rsdp    ResetDP        ; Mark new DP posn in desc, & can't opt back
  6059.     rts
  6060.  
  6061. ; We have the sequence  Dn  <lit>  +/-  @/!
  6062. ; We'll set Dn as the base for the ODnew desc (which is already BD mode).
  6063. ; Then LoadBase can take it from there.  Doing it this way means that we
  6064. ; we can opt back to a preceding descriptor, since the new BD descriptor
  6065. ; completely describes the address.
  6066.  
  6067. .oaD    backDP
  6068.     move.b    opReg,d0
  6069.     lea    ODnew,a0
  6070.     markDP
  6071.     move.b    #mdBD,opMode
  6072.     move.b    d0,opBreg
  6073.     bsr    dropOD    ; Drop the +/- desc
  6074.     bsr    dropOD    ; and the <lit>
  6075.     bsr    dropOD    ; and the Dn
  6076.     rts
  6077.  
  6078. ; A fetch preceded, but it wasn't a literal.  Here we check if the preceding
  6079. ; descriptor indicates a literal fetch.  If so, and the operation is add, we
  6080. ; swap the descriptors so the above code can optimize it.
  6081.  
  6082. .oaNotLit
  6083.     tst.b    LitSub-hbase(a4)
  6084.     bne.s    .no    ; Out if not add
  6085.     downOD
  6086.     cmp.b    #otFetch,(a0)
  6087.     bne.s    .no    ; or if not a fetch
  6088.     cmp.b    #mdLit,opMode
  6089.     bne.s    .no    ; or if not literal
  6090.     backDP        ; Right, we can do it.
  6091.     move.l    a0,a1
  6092.     upOD
  6093.     bsr    exgOD    ; Swap the descriptors
  6094.     downOD
  6095.     get.L    DP,opDP
  6096.     bsr    compFetch    ; Recompile non-literal fetch
  6097.     upOD
  6098.     bra.s    .oaLit    ; and back to the above code to absorb lit.
  6099.  
  6100. .no    lea    ODsav,a0    ; Preceding op was not a literal.
  6101.             ;  We recompile the ADD or SUB to A0, which
  6102.     moveq    #AnReg,d0    ;  we can do since ADDA and SUBA exist.
  6103.     bsr    op2Reg
  6104.     cmp.b    #AnReg,d0    ; Got it in A0?
  6105.     beq.s    .clrbr    ; Yes - fix descriptor and out.
  6106.     or.w    #$2040,d0    ; No. Compile  move.l  dn,a0  first.
  6107.     push.l    d0
  6108.     jsr    wcomma
  6109.     bra.s    .clrbr
  6110.  
  6111.  
  6112. SavOptCode    long
  6113. SavLen    word
  6114.  
  6115. ;        ====================
  6116.  
  6117.  
  6118.     hndlr    at_h,4            ; at_h
  6119.     addq.l    #4,(a6)    ; Skip xinfo flag bytes
  6120.     jsr    length
  6121.     bsr    SaveOD
  6122.     pop.l    D0
  6123.     move.w    D0,(A0)    ; Set type and subtype from caller
  6124.     pop.l    A1    ; and flags
  6125.     move.w    (A1),D0
  6126.     move.b    D0,opFlags
  6127.     move.b    #stkPush,opToFrom    ; Dest = stack
  6128.     move.b    #mdBD,opMode    ; Mode = base-displacement
  6129.     move.b    #stkPop,opBreg    ; Base reg = stack
  6130.     move.b    #1,opind    ; Memory operand (displ = 0)
  6131. atChkOpt    bsr    ChkOpt    ; Previous op?
  6132.     beq    .atNo
  6133.     cmp.b    #otFetch,D1
  6134.     beq.s    .fAt    ; If fetch
  6135.     cmp.b    #otADD,D1
  6136.     blt    .atNo
  6137.     cmp.b    #otSUB,D1
  6138.     bgt    .atNo
  6139.     bsr    optAddr    ; + or -
  6140.     bra.s    .at0
  6141.  
  6142. ; Optimize  fetch @.  We absorb the fetch if possible.
  6143. ; Note:  A0 -> ODnew.
  6144.  
  6145. .fAt    LEA    ODsav,A1
  6146.     CMP.B    #Lcode,opSize(A1)
  6147.     BNE.S    .atNo
  6148.  
  6149. .fat1    BSR    popODts
  6150.     backDP
  6151.     CMPI.B    #mdLit,opMode
  6152.     BNE.S    .atind
  6153.     MOVE.B    #mdAbs,opMode    ; Change Literal mode to Absolute
  6154.     CLR.B    opBreg
  6155.  
  6156. .atind    ADDQ.B    #1,opind    ; For all other modes we just
  6157.             ;  increment the indirection count
  6158. .at0
  6159. fChk    lea    ODsav,a0
  6160.     lea    ODnew,a1
  6161.     cmp.b    #otStore,(A0)    ; Was prev op a store?
  6162.     bne.s    .at1    ; No
  6163.     cmp.b    #stkPop,opToFrom    ; Yes.  Was the stack popped?
  6164.     bne.s    .at1    ; No
  6165.     bsr    CmpAddrs    ; Yes.  Is it the same operand?
  6166.     bne.s    .at1
  6167.     backDP        ; Yes.  we'll just recompile the
  6168.     move.b    #stk,opToFrom    ; store without popping the stack.
  6169.     bsr    CompStore
  6170.     ODvalid
  6171.     rts
  6172.  
  6173. .at1    LEA    ODnew,A0
  6174.     BSR    CompFetch
  6175.     BSR    PushOD
  6176.     RTS
  6177.  
  6178. .atNo    CLR.W    ODsav-hbase(A4)    ; We come here if we can't optimize.
  6179.     BRA.S    .at0    ; We push the desc but mustn't try
  6180.             ; to opt any further back.
  6181.  
  6182.  
  6183.     hndlr    store_h,2            ; store_h
  6184.     addq.l    #4,(a6)    ; Skip xinfo flag bytes
  6185.     pop.l    A0
  6186.     moveq    #0,D0
  6187.     move.w    (A0),D0
  6188.     bsr    SaveOD
  6189.     move.w    D0,(A0)    ; Set type and subtype from caller
  6190.     move.b    #stkPop,opToFrom    ; Source = stack
  6191.     move.b    #mdBD,opMode    ; Mode = base-displacement
  6192.     move.b    #stkPop,opBreg    ; Base reg = stack
  6193.     move.b    #1,opind    ; Memory operand (displ = 0)
  6194. stChkOpt    bsr    ChkOpt    ; Previous op?
  6195.     beq    .stNo
  6196.     cmp.b    #otFetch,D1
  6197.     beq    .ftst    ; If fetch
  6198.     lea    ODsav,A0
  6199.     cmp.b    #otSWAP,D1
  6200.     beq.s    .swapSt    ; If SWAP
  6201.     cmp.b    #otOVER,D1
  6202.     beq.s    .overSt    ; If OVER
  6203.     cmp.b    #otADD,d1
  6204.     blt    .stNo
  6205.     cmp.b    #otSUB,d1
  6206.     bgt    .stNo
  6207.     bsr    optAddr    ; + or -
  6208.     lea    ODnew,a0
  6209.     bra    stChk
  6210.  
  6211. .overSt    BackDP
  6212.     PUSH.L    x2ndToA0
  6213.     JSR    comma
  6214.     LEA    ODnew,A0
  6215.     move.b    #AnReg,opBreg
  6216.     BRA    CompStore
  6217.  
  6218. .swapSt    BackDP
  6219.     compop    xpopD2
  6220.     LEA    ODnew,A0
  6221.     MOVE.B    #2,opToFrom
  6222.     BRA    CompStore
  6223.  
  6224. .compSt
  6225. .stNo    lea    ODnew,a0
  6226.     bsr    CompStore
  6227.  
  6228. .stEnd    lea    ODnew,a0
  6229.     cmp.b    #otStore,operation-hbase(a4)
  6230.     beq    pushOD
  6231.     move.b    #otOp2M,(a0)
  6232.     bra    pushOD
  6233.  
  6234.  
  6235. ; Optimize  fetch, !  (or w! or +! or whatever).
  6236. ; Note:  A0 -> ODnew.
  6237.  
  6238. .ftst    lea    ODsav,A1
  6239.     cmp.B    #Lcode,opSize(A1)
  6240.     bne.S    .stNo
  6241.  
  6242. .fst1    bsr    popODts    ; Combine fetch & store
  6243.     backDP        ;  descriptors in ODnew
  6244.     move.b    #stkPop,opToFrom
  6245.     cmpi.b    #mdLit,opMode
  6246.     beq.s    .stLit
  6247.  
  6248.     addq.b    #1,opind
  6249.     bra.s    .st1
  6250.  
  6251. .stLit    move.b    #mdAbs,opMode
  6252.     clr.b    opBreg
  6253.  
  6254. ; We come here to Stchk from a number of places, when we are doing a store
  6255. ; according to the ODnew descriptor.  This can sometimes be optimized,
  6256. ; depending on what earlier descriptors we find.
  6257.  
  6258. stchk
  6259. .st1    downOD        ; Look at previous desc
  6260. .stReChk    lea    ODnew,a1
  6261.     move.b    (a0),d0
  6262.     cmp.b    #otFetch,d0
  6263.     beq    .mm    ; If a fetch, we'll move mem to mem
  6264.     cmp.b    #otDup,d0
  6265.     beq    .stDup    ; If DUP
  6266.     cmp.b    #otCmp,d0
  6267.     beq    .stCmp    ; If a comparison
  6268.     cmp.b    #otBit,d0
  6269.     beq    .btest    ; If BTEST
  6270.     cmp.b    #otFPops,d0
  6271.     blt.s    .st2
  6272.     cmp.b    #otFPend,d0
  6273.     blt    .stFP    ; If a floating-point op
  6274. .st2    cmp.b    #otPMops,d0
  6275.     blt    .compSt    ; If not integer op, just do the store
  6276.     cmp.b    #otPMend,d0
  6277.     bge    .compSt
  6278.  
  6279. ; The previous operation is an integer arithmetic/logical op.
  6280.  
  6281.     cmp.b    #otMon,d0
  6282.     bge    .stMon    ; If monadic
  6283.  
  6284. ; It's a dyadic op.  If destination is Dn direct, and this is a straight
  6285. ; store (not ++> etc.) we use that reg as the work reg for the arithmetic.
  6286. ; Otherwise we use D1 and then store D1 to the destination.
  6287.  
  6288. ; NOTE: Don't ever include An direct here as a work reg for add or sub,
  6289. ; although we do for fetches.  If we did that, we could have an A reg
  6290. ; conflict, since A0 can be used as a work reg for arithmetic for a fetch,
  6291. ; and in that case A1 could be in use as a work reg for LoadBase for the
  6292. ; same fetch (if we chain an arith op with an operand from memory).
  6293. ; Thus we'd have no available A reg.  It's not worth bothering to
  6294. ; specifically check for this case, which is rather weird anyway.
  6295.  
  6296. .stpm0    CMP.B    #mdDn,opMode(A1)    ; Is destination Dn direct?
  6297.     BNE.S    .st3
  6298.     CMP.B    #1,opind(A1)
  6299.     BNE.S    .st3
  6300.     CMP.B    #otStore,(A1)
  6301.     BNE.S    .st3    ; and a straight store?
  6302.     MOVEQ    #0,D6    ; Yes - we'll use Dn as an operand reg
  6303.     MOVE.B    opReg(A1),D6
  6304.     BRA.S    .stpm1
  6305.  
  6306. .st3    MOVEQ    #1,D6    ; No - we'll use D1 as a temporary
  6307.  
  6308. .stpm1    MOVE.L    D6,D0
  6309.     BSR    op2Reg    ; Recompile op to Dn
  6310.     CMP.B    D0,D6
  6311.     BNE.S    .stpmMv
  6312.     CMP.B    #1,D6
  6313.     BNE.S    .stpm2    ; and, if necessary:
  6314. .stpmMv    LEA    ODnew,A0
  6315.     markDP
  6316.     MOVE.B    #1,opToFrom    ;    MOVE.x    D1,<dest ea>
  6317.     BRA    .compSt    ; (Dn above will have been D1 in this case)
  6318.  
  6319. .stpm2    MOVE.B    D6,opToFrom(A1)
  6320.     MOVE.L    A1,A0
  6321.     markDP
  6322.     bra    .stEnd
  6323.  
  6324. ; Preceding op was a monadic arith/logical op.  We check for the case where
  6325. ; there is a preceding fetch specifying the same operand as the destination.
  6326. ; In this case we can operate straight on the destination.  Otherwise we go
  6327. ; back to stpm0 and handle it as for the dyadic ops.  We also do this for
  6328. ; constant shifts, since we can't do these directly in memory.  (All right,
  6329. ; I know we can do a word shift of one place in memory, but this is
  6330. ; pretty well useless in the Mops environment, so we don't bother about it.)
  6331.  
  6332. .stMon    move.b    d0,operation-hbase(a4)    ; Ready for OP2 if needed
  6333.     move.b    opShiftCnt,shiftCnt-hbase(a4)
  6334.     DownOD
  6335.     cmp.b    #otFetch,(a0)
  6336.     bne.s    .stmNo
  6337.     bsr    CmpAddrs
  6338.     bne.s    .stmNo
  6339.     cmp.b    #otSHIFT,operation-hbase(a4)
  6340.     beq.s    .stmNo
  6341.  
  6342.     backDP
  6343.     exg    a0,a1
  6344.     markDP
  6345.     bsr    newOD
  6346.     moveq    #1,d0
  6347.     bsr    LoadBase
  6348.     exg    a0,a1
  6349.     bsr    OP2
  6350.     bsr    releaseOD
  6351.     bra    .stEnd
  6352.  
  6353. .stmNo    upOD
  6354.     bra    .stpm0
  6355.  
  6356. ; Preceding op was DUP.
  6357.  
  6358. .stDup    BackDP        ; Wipe out the DUP
  6359.     LEA    ODnew,A0    ;  - we just don't pop when we store.
  6360.     MOVE.B    #stk,opToFrom
  6361.     get.L    DP,opDP    ; Put right DP value in descriptor
  6362.     BRA    .compSt
  6363.  
  6364. ; Preceding op was Fetch.
  6365.  
  6366. .mm    BackDP
  6367.     cmp.b    #mdLit,opMode    ; Was it a literal?
  6368.     beq.s    .litSt    ; Yes
  6369.  
  6370. .mm2    MOVE.L    A0,A1    ; Save A0 across LoadBase call
  6371.     MOVEQ    #0,D0
  6372.     BSR    LoadBase    ; Load base for source and set A0 desc
  6373.     EXG    A0,A1
  6374.     upOD
  6375.     MOVEQ    #1,D0
  6376.     st    StoreFlg-hbase(a4)
  6377.     BSR    LoadBase    ; Load base for dest, specifying A1
  6378.     move.b    #fromMem,opToFrom    ; Mark as mem to mem store
  6379.     EXG    A0,A1    ; A0 -> src desc, A1 -> dest
  6380.     BSR    CompStore1
  6381.     BRA    .stEnd
  6382.  
  6383. .litSt            ; We're storing a literal.  If it's a -1
  6384.             ; being stored in a byte, we can use ST
  6385.     lea    ODnew,A1
  6386.     cmp.b    #Ccode,opSize(A1)
  6387.     bne.s    .mm2    ; If not a byte store, don't opt
  6388.     cmp.l    #-1,opLit
  6389.     bne.s    .mm2    ; If lit not -1, don't opt
  6390.     move.w    #$50C0,D0
  6391.     lea    ODnew,A0
  6392.     bra    CompMop2    ; Compile  ST <ea>
  6393.  
  6394.  
  6395. ; Preceding op was a comparison.  If this is a byte store, we can
  6396. ; optimize this to an Scc instruction.
  6397.  
  6398. .stCmp    LEA    ODnew,A1
  6399.     CMP.B    #Ccode,opSize(A1)
  6400.     BNE    .compSt    ; If not a byte store, don't opt
  6401.     CLR.B    Rcond-hbase(A4)
  6402.     BSR    optCMP    ; Optimize the CMP
  6403.     lea    ODsav,a0
  6404.     cmp.b    #otCmp,(a0)
  6405.     bne    .stReChk    ; If CMP desc has vanished altogether, go back
  6406.     lea    ODnew,a0
  6407.     bsr    CompScc
  6408.     bra    .stEnd
  6409.  
  6410. ; Preceding op was a BTEST.  This is a bit like a comparison.
  6411.  
  6412. .btest    lea    ODnew,a1
  6413.     cmp.b    #Ccode,opSize(a1)
  6414.     bne    .compSt
  6415.     geta    DP,a0
  6416.     subq.l    #4,(a0)
  6417.     move.w    #$56C0,d0    ; Scc opcode is always SNE here
  6418.     lea    ODnew,a0
  6419.     bsr    CompMop2
  6420.     bra    .stEnd
  6421.  
  6422. ; Preceding op was a floating-point op.
  6423.  
  6424. .stFP    cmp.b    #mdFPn,opMode(a1)    ; Is store destination FPn?
  6425.     bne.s    .fp1
  6426.     cmp.b    #otStore,(a1)    ; And is this a straight store?
  6427.     bne.s    .fp1
  6428.     move.b    opReg(a1),d6    ; Yes - we'll recompile the op there
  6429.     bra.s    .fp2
  6430.  
  6431. .fp1    moveq    #1,d6    ; No - we'll use FP1 as a temporary
  6432.  
  6433. .fp2    move.l    d6,d0
  6434.     bsr    FPop2reg    ; Recompile the FP op to FPn
  6435.     cmp.b    d0,d6
  6436.     bne.s    .fp3
  6437.     cmp.b    #1,d6
  6438.     bne.s    .stpm2
  6439.  
  6440. .fp3    lea    ODnew,A0    ; and, if necessary, move the temp FP1 to
  6441.     markDP        ;  destination.
  6442.     or.b    #FPnReg,d0
  6443.     move.b    d0,opToFrom
  6444.     bra    .compSt
  6445.     
  6446.  
  6447. ;    ====================================
  6448.  
  6449. ;        TESTS, COMPARES etc.
  6450.  
  6451. ;    ====================================
  6452.  
  6453. ifFlg    byte
  6454.     align
  6455.  
  6456. DataFetch            ; Returns with CC = EQ if A0 desc is a data
  6457.     loc        ; fetch - this includes literals, but not addr fetches.
  6458.     CMP.B    #otFetch,(A0)
  6459.     BNE.S    .out
  6460.     CMP.B    #mdLit,opMode
  6461.     BEQ.S    .out
  6462.     TST.B    opind
  6463.     SEQ    D0
  6464.     TST.B    D0
  6465. .out    RTS
  6466.  
  6467.  
  6468. FPfetch            ; Returns with CC = EQ if A0 desc is a
  6469.     loc        ; floating-point fetch.
  6470.     cmp.b    #otFetch,(a0)
  6471.     bne.s    .out
  6472.     btst    #flFP,opFlags
  6473.     seq    d0
  6474.     tst.b    d0
  6475. .out    rts
  6476.  
  6477.  
  6478. ; Ftch2TST converts the A0 descriptor (which must be a fetch) to a TST.
  6479.  
  6480. Ftch2TST
  6481.     loc
  6482.     moveq    #0,d0
  6483.     cmp.b    #mdLit,opMode
  6484.     beq    CCmp
  6485.     move.l    a0,a1
  6486.     downOD
  6487.     cmp.b    #otStore,(A0)
  6488.     beq.s    .cmpAd
  6489.     cmp.b    #otOp2M,(a0)
  6490.     bne.s    .f2tTST
  6491.  
  6492. .cmpAd    BSR    CmpAddrs
  6493.     BNE.S    .f2tTST    ; If we just stored or operated to the same
  6494.     upOD        ;  location, the CC will be OK already, so we
  6495.     backDP        ;  omit the test altogether.
  6496.     RTS
  6497.  
  6498. .f2tTST    MOVE.L    A1,A0    ; Restore appropriate desc ptr to A0
  6499.     TST.B    opind
  6500.     BEQ.S    .tstAddr
  6501.     st    ForceToR-hbase(a4)
  6502.     st    InhibitClr-hbase(a4)
  6503.     clr.b    opToFrom    ; And compile a fetch to D0 (same effect as
  6504.     bra    CompFetch    ;  a test, but PC-rel mode works).
  6505.  
  6506. .tstAddr
  6507.     MOVEQ    #0,D0
  6508.     BSR    CompLEA
  6509.     compop    xTSTA0
  6510.     RTS
  6511.  
  6512.  
  6513. ; FPftch2TST is the floating-point equivalent of Ftch2TST.  We don't worry
  6514. ; about as many optimizations, which shouldn't matter here.  All we do is
  6515. ; recompile the fetch to go to FP0, since this sets the FCC and is about the
  6516. ; same speed as a FTST.  But especially, we already have code around to do it!
  6517.  
  6518. FPftch2TST
  6519.     moveq    #0,d0
  6520.     bra    CompMoveToFPn    ; Easy, wasn't it?
  6521.  
  6522.  
  6523. ; Ftch2CMP converts the A0 descriptor (which must be a fetch) to a CMP.
  6524.  
  6525. Ftch2CMP
  6526.     MOVEQ    #0,D0
  6527.     BSR    LoadBase
  6528.     MOVE.W    #$B000,D0
  6529.     BRA    CompMOp
  6530.  
  6531.  
  6532. ; CompTST is called to compile a TST on the top of the stack.  We check
  6533. ; for a few optimization possibilities.  Entered with A0 -> appropriate
  6534. ; descriptor.
  6535.  
  6536. CompTST
  6537.     move.b    (a0),d0
  6538.     CMP.B    #otDUP,d0    ; Was last op DUP?
  6539.     BEQ.S    .ctDup    ; Yes
  6540.     CMP.B    #otStore,d0    ; No.  Was it Store?
  6541.     beq.s    .ctSt    ; Yes
  6542.     cmp.b    #otPMops,d0    ; No.  Was it an integer arith op?
  6543.     blt.s    .ctTSTpop    ; If not, compile normal TST with pop.
  6544.     cmp.b    #otPMend,d0
  6545.     bge.s    .ctTSTpop
  6546.  
  6547. ; Last op was an integer arith op.
  6548.  
  6549.     moveq    #1,d0
  6550.     bra    op2reg    ; Recompile op to D1 - CC will be OK
  6551.             ;  and that's all, folks!
  6552.  
  6553. ; Last op was a store.
  6554.  
  6555. .ctSt    CMP.B    #stk,opToFrom    ; Was it an unpopped stack store?
  6556.     BNE.S    .ctTSTpop    ; No
  6557.     backDP        ; Yes, so it's the same operand, and
  6558.     MOVE.B    #stkPop,opToFrom    ;  CC will be OK.  So we recompile the
  6559.     BRA    CompStore    ;  store with a pop, and that's all.
  6560.  
  6561. ; Last op was DUP.
  6562.  
  6563. .ctDup    backDP        ; Omit it
  6564.     downOD        ; Look at prev op
  6565.     CMP.B    #otStore,(A0)    ; Did it leave the run-time CC ok?
  6566.     BLE.S    .ctTST
  6567.     CMP.B    #otCCok,(A0)
  6568.     BLE.S    .ctRtn    ; Yes - no need to test, and no stack
  6569.             ; effect.  So we don't compile anything.
  6570. .ctTST    compop    xTSTstk    ; No - TST stack without pop
  6571.     RTS
  6572.  
  6573. .ctTSTpop
  6574.     compop    xTSTstkPop    ; Normal TST with pop.
  6575. .ctRtn    RTS
  6576.  
  6577.  
  6578. ; CompFTST is called to compile a floating-point test on the top of the stack.
  6579. ; The result will be in the floating condition code.  As for CompTST, we check
  6580. ; for optimization possibilities.
  6581. ; Entered with A0 -> appropriate descriptor.
  6582.  
  6583. CompFTST
  6584.     move.b    (a0),d0
  6585.     cmp.b    #otFPops,d0    ; Was last op an FP arith op?
  6586.     blt.s    .cftTSTpop    ; If not, compile normal FTST with pop.
  6587.     cmp.b    #otFPend,d0
  6588.     bge.s    .cftTSTpop
  6589.  
  6590. ; Last op was an FP arith op.
  6591.  
  6592.     BackDP
  6593.     moveq    #1,d0
  6594.     bra    FPop2reg    ; Recompile op to FP1 - FCC will be OK
  6595.             ;  and that's all, folks!
  6596.  
  6597. .cftTSTpop
  6598.     moveq    #0,d0    ; Rather than compile a FTST, we just
  6599.     bra    CompPopFPn    ; pop the top operand to FP0.  That is easier,
  6600.             ; it sets the FCC just as well, and is close
  6601.             ; to the same speed.
  6602.  
  6603. ;        ========================
  6604.  
  6605. ; Comparisons.
  6606.  
  6607. ; When we get a comparison op, we just push a descriptor and don't worry
  6608. ; about optimization straight away.  This is because it's a bit fiddly to
  6609. ; generate a boolean flag on the stack (needing an Scc, two EXT instructions
  6610. ; and a move) so in the unoptimized case we just call a subroutine.
  6611. ; But if the following op just needs the condition code, we can bypass
  6612. ; the generation of the boolean, which means that we can compile inline code.
  6613. ; So, when we get a suitable following op, and we look down and see the
  6614. ; comparison descriptor, we call OptCMP to generate optimized inline code for
  6615. ; the comparison, replacing the default subroutine call.
  6616. ; Entered with A0 -> comparison descriptor.
  6617.  
  6618. ; The order of the operands is a bit tricky.  For normal arithmetic operations,
  6619. ; when we call OP2, A0 points to the source descriptor and A1 to the destination.
  6620. ; This results in the operands being the other way around to the Forth order - if
  6621. ; we have  a b -  we need to subtract b from a, so when we call OP2, A0 will point
  6622. ; to the b descriptor and A1 to the a descriptor.
  6623. ; Therefore, to be consistent, we do the same thing for comparisons.  Thus if we
  6624. ; have  a b >  we need to call OP2 with  A0 -> b  and  A1 -> a.  As comparisons
  6625. ; don't store a result, it will sometimes be easier to call OP2 with the descriptors
  6626. ; the other way around, as this won't mess anything up.  In this case, we will call
  6627. ; RevCond to reverse the test condition.  In practice it isn't always easy to keep
  6628. ; track of when to call RevCond, and we've resorted to good old trial and error on
  6629. ; a few occasions!!
  6630.  
  6631. optCMP
  6632.     loc
  6633. .loop    BackDP
  6634.     move.b    #otCMP,operation-hbase(A4)
  6635.     move.l    a0,CMPdesc-hbase(a4)    ; Save desc ptr for RevCond
  6636.     MOVE.B    1(A0),D2    ; Subtype code (comparison type) to D2
  6637.     MOVEQ    #$F,D0
  6638.     AND.B    D2,D0
  6639.     MOVE.B    D0,condition-hbase(A4)
  6640.     CMP.B    #$F,D2    ; 2-op or 1-op?
  6641.     BLE.S    .2op    ; If 2-op
  6642.  
  6643. ; One operand - e.g.  0>
  6644.  
  6645.     CMP.W    #tsZNE,(A0)
  6646.     beq.s    .zne    ; If this comp is 0<>
  6647.     DownOD
  6648. .chkDF    bsr    DataFetch    ; Was prev op a data fetch?
  6649.     beq.s    .ftch    ; Yes - convert to test
  6650.     bra    compTST    ; No - compile test
  6651.  
  6652. .zne    DownOD
  6653.     cmp.b    #otCMP,(a0)    ; This op was 0<>.  Prev op another compare?
  6654.     beq.s    .cmp1st    ; Yes - drop the 0<>
  6655.     cmp.b    #otFetch,(a0)    ; If it is a literal fetch of -1 or 0,
  6656.     bne    compTST    ;  we likewise drop the 0<>.  Otherwise
  6657.     cmp.b    #mdLit,opMode    ;  we compile a test.
  6658.     bne.s    .ftch
  6659.     cmp.l    #-1,opLit
  6660.     beq.s    .Lit1st
  6661.     tst.l    opLit
  6662.     bne.s    .ftch
  6663.  
  6664. .Lit1st    BackDP
  6665.     bra    DropOD
  6666.  
  6667. .cmp1st    bsr    dropOD    ; Compare followed by 0<>.  Drop the latter
  6668.     move.l    CMPdesc,a0
  6669.     bra    .loop    ;  and loop.
  6670.  
  6671. .ftch    BackDP        ; Prev op was a fetch
  6672.     BRA    Ftch2TST    ; Convert it to a TST.
  6673.  
  6674. ; 2 operand compare, e.g.  >
  6675.  
  6676. .2op    downOD
  6677.     BSR    DataFetch    ; Was prev op a data fetch?
  6678.     BEQ.S    .f2    ; Yes
  6679.  
  6680. .2op1    CMPI.B    #otOVER,(A0)    ; No.  OVER?
  6681.     BNE    .2comp    ; No. Just optimize the compare.
  6682.  
  6683. ; We have OVER followed by a 2-op compare.  This will happen in a
  6684. ; CASE ...  OF  construction, so it is worth optimizing.
  6685.  
  6686.     BackDP        ; We'll absorb the OVER somehow.
  6687.     DownOD
  6688.     CMP.B    #otFetch,(A0)    ; Was previous op a fetch? (any fetch OK 
  6689.             ;  here)
  6690.     BNE    .ovcmp    ; No
  6691.     BackDP        ; Yes
  6692. .nopop    move.l    a0,a1
  6693.     UseODsrc        ; Set stack not to pop
  6694.     exg    a0,a1
  6695.     MOVE.B    #stk,opMode(A1)    ; Stack operand is really the "b" operand
  6696.     moveq    #0,d0
  6697.     bsr    LoadBase    ; LoadBase for the fetched operand (the "a" 
  6698.             ;  operand)
  6699.     exg    a0,a1    ; We need a0 -> b, a1 -> a (see introduction)
  6700.     bra    OP2
  6701.  
  6702. .ovcmp    compop    xpopD2    ;    pop.l    d2
  6703.     compop    xcmpD2    ;    cmp.l    (a6),d2
  6704.     rts        ; Working out why we don't need to call RevCond
  6705.             ;  is decidedly non-trivial!  But it's true!!
  6706.             ;  (Actually I found out by trial and error)
  6707.  
  6708. ; We have a fetch followed by a 2-op compare
  6709.  
  6710. .f2    backDP        ; Back the DP to the fetch
  6711.     downOD
  6712.     bsr    DataFetch    ; Was op before that a data fetch?
  6713.     beq.s    .ff    ; Yes
  6714.  
  6715. .f21    cmp.b    #otDup,(a0)    ; Was it DUP?
  6716.     beq.s    .df    ; Yes
  6717.     cmp.b    #otPMops,(a0)
  6718.     blt    .fcmp    ; If not an integer arithmetic op
  6719.     cmp.b    #otPMend,(a0)
  6720.     bge    .fcmp
  6721.  
  6722. ; We have <integer op>, fetch, compare.  We recompile the integer op to D1.
  6723. ; We then call OP2 with A0 -> fetch desc, A1 -> D1 desc.  This is the "right" way
  6724. ; around, so we don't need to call RevCond.
  6725.  
  6726.     push.l    a0    ;  as needed for Op2Reg
  6727.     move.b    operation,d0
  6728.     push.w    d0
  6729.     moveq    #1,d0
  6730.     bsr    Op2reg    ; Recompile preceding op to D1
  6731.     pop.w    d1
  6732.     move.b    d1,operation-hbase(a4)
  6733.     bsr    newClrOD
  6734.     move.b    #mdDn,opMode
  6735.     move.b    d0,opReg
  6736.     move.l    a0,a1
  6737.     pop.l    a0
  6738.     upOD
  6739.     moveq    #0,d0
  6740.     bsr    LoadBase
  6741.     bsr    OP2
  6742.     bsr    releaseOD
  6743.     rts
  6744.  
  6745. ; We have DUP, fetch, compare.
  6746.  
  6747. .df    backDP        ; Absorb the DUP and set the stack
  6748.     upOD        ;  not to pop. This is like  fetch OVER compare
  6749.     BSR    RevCond    ;  but the operands are reversed.
  6750.     BRA.S    .nopop
  6751.  
  6752. ; Optimize a fetch, fetch, compare sequence.
  6753.  
  6754. .ff    BackDP
  6755.     MOVE.L    A0,A1    ; Save A0 across LoadBase call
  6756.     MOVEQ    #0,D0
  6757.     BSR    LoadBase    ; Load base for "a"
  6758.     EXG    A0,A1
  6759.     upOD
  6760.     MOVEQ    #1,D0
  6761.     BSR    LoadBase    ; Load base for "b"
  6762.             ; A0 -> "b", A1 -> "a" - the "right" way around
  6763.     BRA    OP2
  6764.  
  6765.  
  6766. ; Optimize just a fetch, compare sequence.  The stack is the "a" operand, and
  6767. ; the fetch is "b".  We'll call OP2 with A1 -> "b", since OP2 will then recompile
  6768. ; the fetch to Dn.  This is the "wrong" way around, so we'll call RevCond.
  6769.  
  6770. .fcmp    UpOD
  6771.     moveq    #0,d0
  6772.     bsr    LoadBase    ; LoadBase for the fetch
  6773.     move.l    a0,a1
  6774.     UseODsrc
  6775.     exg    a0,a1
  6776.     move.b    #stkPop,opMode(a1)
  6777.     BRA    OP2
  6778.  
  6779. ; Optimize just a 2-op compare - replace by  CMPM.L  (A6)+,(A6)+
  6780. ; Note we can come here whatever descriptor A0 is pointing to.  Note that these
  6781. ; operands are the "right" way around.
  6782.  
  6783. .2comp    compop    xcmp    ; 2-op - compile CMPM.L (A6)+,(A6)+
  6784.     rts
  6785.  
  6786.  
  6787. ; OptFCMP is the floating-point equivalent of OptCMP.  At present we're not
  6788. ; worrying about FDUP or FOVER optimization.  It's better to use FP locals
  6789. ; as much as possible, anyway.
  6790. ; The entry point CompFCMP is called from FPcmp_h to compile a FCMP.  (We don't
  6791. ; do the equivalent in integer mode since we call a subroutine.  But custom
  6792. ; FPU code is a lot better than general code, so we use it if we can.)
  6793. ; Entered with A0 -> comparison descriptor.
  6794.  
  6795. optFCMP
  6796.     loc
  6797.     BackDP
  6798.  
  6799. CompFCMP
  6800.     clr.b    FPA-hbase(a4)
  6801.     move.b    #otFPcmp,operation-hbase(A4)
  6802.     move.l    a0,CMPdesc-hbase(a4)    ; Save desc ptr for RevCond
  6803.     move.b    1(a0),d2    ; Subtype code (comparison type) to D2
  6804.     moveq    #$F,d0
  6805.     and.b    d2,d0
  6806.     move.b    d0,condition-hbase(a4)
  6807.     cmp.b    #$F,d2    ; 2-op or 1-op?
  6808.     ble.s    .2op    ; If 2-op
  6809.  
  6810. ; One operand - e.g.  F0>
  6811.  
  6812.     DownOD
  6813.     bsr    FPfetch    ; Was prev op an FP fetch?
  6814.     bne.s    compFTST    ; No - compile test
  6815.  
  6816.     BackDP        ; Yes - convert fetch to a test
  6817.     bra    FPftch2TST
  6818.  
  6819. ; 2 operand compare, e.g.  F>
  6820.  
  6821. .2op    downOD
  6822.     bsr    FPfetch    ; Was prev op an FP fetch?
  6823.     bne    .2comp    ; No. Just compile the compare.
  6824.  
  6825. ; We have a fetch followed by a 2-op compare.
  6826.  
  6827. .f2    backDP        ; Back the DP to the fetch
  6828.     downOD
  6829.     bsr    FPfetch    ; Was op before that an FP fetch?
  6830.     beq.s    .ff    ; Yes
  6831.     cmp.b    #otFPops,(a0)
  6832.     blt    .fcmp
  6833.     cmp.b    #otFPend,(a0)
  6834.     bge    .fcmp
  6835.  
  6836. ; We have <floating-op>, fetch, compare.  We recompile the FP op to an FP reg.
  6837. ; We then call OP2 with A0 -> fetch desc, A1 -> FPn desc.  This is the "right" way
  6838. ; around, so we don't need to call RevCond.
  6839.  
  6840.     push.l    a0
  6841.     move.b    operation,d0
  6842.     push.w    d0
  6843.     moveq    #0,d0
  6844.     bsr    FPop2reg    ; Recompile preceding op to FP0 or FP1
  6845.     pop.w    d1
  6846.     move.b    d1,operation-hbase(a4)
  6847.     bsr    newClrOD
  6848.     move.b    #mdFPn,opMode
  6849.     move.b    #fbFP,opFlags
  6850.     move.b    d0,opReg
  6851.     move.l    a0,a1
  6852.     pop.l    a0
  6853.     upOD
  6854.     moveq    #0,d0
  6855.     bsr    LoadBase
  6856.     bsr    OP2
  6857.     bsr    releaseOD
  6858.     rts
  6859.  
  6860. ; We have fetch, fetch, compare.  We avoid a RevCond call by calling OP2
  6861. ; with the descriptors the "right" way around, unless the "b" (A0) operand turns
  6862. ; out to be an FP reg, and the "a" operand (A1) isn't.  In this case we avoid an
  6863. ; extra FMOVE at run time by calling RevCond and reversing the descriptors.
  6864.  
  6865. .ff    BackDP
  6866.     move.l    a0,a1    ; Save A0 across LoadBase call
  6867.     moveq    #0,d0
  6868.     bsr    LoadBase    ; Load base for "a"
  6869.     exg    a0,a1
  6870.     upOD
  6871.     moveq    #1,d0
  6872.     bsr    LoadBase    ; Load base for "b"
  6873.     cmp.b    #mdFPn,opMode(a1)    ; Is "a" FPn?
  6874.     beq.s    .ffop2    ; Yes - just call OP2
  6875.     cmp.b    #mdFPn,opMode(a0)    ; No  - is "b" FPn?
  6876.     bne.s    .ffop2    ;   No  - just call OP2
  6877.     bsr    RevCond    ;   Yes - call RevCond and reverse descriptors
  6878.     exg    a0,a1
  6879. .ffop2    bsr    OP2
  6880.     rts
  6881.  
  6882. ; Optimize just a fetch, compare sequence.  The stack is the "a" operand, and
  6883. ; the fetch is "b".  We'll call OP2 with A1 -> "b", since OP2 will then recompile
  6884. ; the fetch to FP0 unless the operand is already in an FP reg.
  6885. ; This is the "wrong" way around, so we call RevCond.
  6886.  
  6887. .fcmp    UpOD
  6888.     bsr    RevCond
  6889.     BackDP
  6890.     moveq    #0,d0
  6891.     bsr    LoadBase
  6892.     move.l    a0,a1
  6893.     UseODsrc
  6894.     move.b    #stkPop,opMode
  6895.     bra    OP2
  6896.  
  6897. ; We have just a 2-op compare.  The TOS is "b" and the second cell is "a".
  6898. ; There's no mem-to-mem floating compare, and as with all FP ops the "destination"
  6899. ; operand of FCMP must be FPn.
  6900. ; So we pop the TOS ("b") to FP0, then call OP2 with A0 (source) = stack ("a")
  6901. ; and A1 (dest) = FP0 ("b").  This is the "wrong" way around, so we call RevCond.
  6902.  
  6903. .2comp    bsr    RevCond
  6904.     st    FPdispFlg-hbase(a4)    ; 2 to dispose
  6905.     moveq    #0,d0
  6906.     bsr    CompPopFPn
  6907.     bsr    NewClrOD
  6908.     move.b    #mdFPn,opMode
  6909.     move.b    #fbFP,opFlags
  6910.     move.l    a0,a1
  6911.     bsr    NewClrOD
  6912.     move.b    #stkPop,opMode
  6913.     bsr    OP2
  6914.     bsr    releaseOD
  6915.     bsr    releaseOD
  6916.     rts
  6917.  
  6918.  
  6919. ; CompScc compiles an Scc instruction, following a comparison.
  6920. ; The A0 descriptor gives the ea for the operation.
  6921.  
  6922. CompScc    MOVE.B    condition,D0
  6923.     MOVE.B    RCond,D1
  6924.     EOR.B    D1,D0    ; Alter test condition if nec
  6925.     LSL    #8,D0    ; Shift condition into position
  6926.     OR.W    #$50C0,D0    ; Form Scc opcode in D0
  6927.     BRA    CompMop2    ; Compile  Scc <ea>
  6928.  
  6929.  
  6930.  
  6931. ; (IF)  ( b -- ) Handles IF and NIF as far as compiling the branch opcode.
  6932. ; It checks if optimization is possible, by checking the previous descriptors
  6933. ; for various  possibilities.  If optimization is possible, the code is
  6934. ; recompiled appropriately, and the right Bcc is compiled.
  6935. ; If no optimization is done, the code just generated remains unchanged,
  6936. ; and a BEQ or BNE opcode is compiled.
  6937. ; Note that we don't try to optimize if a preceding fetch is an address
  6938. ; fetch, since a CMP can't be done on An.
  6939. ;
  6940. ; The passed-in boolean is false for NIF and true for IF - we use this flag
  6941. ; to decide whether to invert the branch condition (IF produces a branch if
  6942. ; the condition just tested is false).
  6943. ;
  6944. ; The flag CCmpFlg is left indicating if a test on a literal was done.  We
  6945. ; evaluate this condition at compile time, and leave the flag as follows:
  6946. ;
  6947. ;    0    normal
  6948. ;    1    always branch
  6949. ;    2    never branch
  6950. ;
  6951. ; For a forward "always branch" situation, >RESOLVE actually deletes the
  6952. ; code being branched over (which could never be executed).
  6953.  
  6954.     loc
  6955. pif    move.b    #6,condition-hbase(a4)    ; Initial condition is "not equal"
  6956.     moveq    #1,d0
  6957.     and.l    (a6)+,d0
  6958.     move.b    d0,RCond-hbase(a4)    ; Save: true for reverse condition (if)
  6959.     st    ifFlg-hbase(a4)    ; Setting this flag shows conditional
  6960.     bsr    SaveOD    ;  compilation may be possible
  6961.     lea    ODsav,A0
  6962.     bsr    ChkOpt    ; Any optimization possibilities?
  6963.     beq.s    .no    ; No
  6964.     cmp.b    #otCmp,D1
  6965.     beq.s    .comp    ; If comparison op
  6966.     bsr    DataFetch
  6967.     beq.s    .ftch    ; If data fetch
  6968.     cmp.b    #otBit,D1
  6969.     beq.s    .btest    ; If BTEST
  6970.     cmp.b    #otFPcmp,d1
  6971.     beq.s    .Fcomp    ; If floating-point comparison op
  6972.     cmp.b    #otPMops,D1
  6973.     blt.s    .no
  6974.     cmp.b    #otPMend,D1
  6975.     bge.s    .no
  6976.  
  6977. ; Last op is an integer arith op, including AND, OR and XOR.
  6978.  
  6979.     moveq    #1,d0
  6980.     bsr    op2reg    ; Recompile op to D1
  6981.     bra    .getcode    ;  and the CC will be OK now.
  6982.  
  6983. ; No optimization.
  6984.  
  6985. .no    BSR    CompTST
  6986.     BRA    .getcode
  6987.  
  6988. ; Last op is a comparison.
  6989.  
  6990. .comp    BSR    optCMP    ; Optimize it
  6991.     BRA.S    .getcode
  6992.  
  6993. ; Last op is a floating-point comparison
  6994.  
  6995. .Fcomp    bsr    optFCMP    ; Optimize it
  6996.     sf    d7    ; Clear flag so FBcc will be compiled,
  6997.     bra.s    .gc1    ;  not Bcc
  6998.  
  6999. ; Fetch - e.g.  bloggs IF
  7000.  
  7001. .ftch    BackDP
  7002.     BSR    Ftch2TST
  7003.     BRA.S    .getcode
  7004.  
  7005. .btest    geta    DP,a0
  7006.     subq.l    #4,(a0)
  7007.  
  7008. ; We come here with correct opcode byte in Condition.
  7009.  
  7010. .getcode
  7011.     st    d7    ; Set flag to show normal Bcc to be
  7012.             ;  compiled (not FBcc)
  7013. .gc1    sf    ifFlg-hbase(a4)    ; Clear conditional comp enabling flag
  7014.     get.b    CCmpFlg,d0
  7015.     bne.s    .pifEnd
  7016.     moveq    #0,d0
  7017.     move.b    condition,d0
  7018.     move.b    RCond,d1
  7019.     clr.b    RCond-hbase(a4)
  7020.     eor.b    d1,d0    ; Alter test condition if nec
  7021.     tst.b    d7    ; Bcc or FBcc?
  7022.     beq.s    .gcFBcc
  7023.             ; Bcc
  7024.     or.b    #$60,d0    ; Form Bcc opcode byte
  7025.     lsl    #8,d0    ; Shift opcode into position
  7026. .gcCom    push.l    d0    ; Compile it, return
  7027.     jsr    wcomma
  7028. .pifEnd    rts
  7029.  
  7030. .gcFBcc            ; FBcc to be compiled
  7031.     lea    int2FPconditions,a0
  7032.     move.b    0(a0,d0.w),d0    ; Convert condition bits to FP equivalent
  7033.     or.w    #$F280,d0    ; FBcc opcode
  7034.     bra.s    .gcCom
  7035.